! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes destructors fry kernel math namespaces
-prettyprint sequences sets sorting ;
+prettyprint sequences sets sorting continuations accessors arrays
+io io.styles combinators.smart ;
IN: tools.destructors
<PRIVATE
-: disposable-tally ( -- assoc )
- disposables get
- H{ } clone [ [ keys ] dip '[ class _ inc-at ] each ] keep ;
+: class-tally ( assoc -- assoc' )
+ H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ;
-: subtract-values ( assoc1 assoc2 -- assoc )
- [ [ keys ] bi@ append prune ] 2keep
- H{ } clone [
- '[
- [ _ _ [ at 0 or ] bi-curry@ bi - ] keep _ set-at
+: (disposables.) ( assoc -- )
+ class-tally >alist [ first2 [ length ] keep 3array ] map [ second ] sort-with
+ standard-table-style [
+ [
+ [ "Disposable class" write ] with-cell
+ [ "Instances" write ] with-cell
+ [ ] with-cell
+ ] with-row
+ [
+ [
+ [
+ [ pprint-cell ]
+ [ pprint-cell ]
+ [ [ "[ List instances ]" swap write-object ] with-cell ]
+ tri*
+ ] input<sequence
+ ] with-row
] each
- ] keep ;
+ ] tabular-output nl ;
-: (disposables.) ( assoc -- )
- >alist sort-keys simple-table. ;
+: sort-disposables ( seq -- seq' )
+ [ disposable? ] partition [ [ id>> ] sort-with ] dip append ;
PRIVATE>
: disposables. ( -- )
- disposable-tally (disposables.) ;
+ disposables get (disposables.) ;
+
+: disposables-of-class. ( class -- )
+ [ disposables get values sort-disposables ] dip
+ '[ _ instance? ] filter stack. ;
: leaks ( quot -- )
- disposable-tally [ call disposable-tally ] dip subtract-values
- (disposables.) ; inline
+ disposables get clone
+ debug-leaks? on
+ [
+ [ call disposables get clone ] dip
+ ] [ ] [ debug-leaks? off ] cleanup
+ assoc-diff (disposables.) ; inline
! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel namespaces make
-sequences vectors sets assocs init ;
+sequences vectors sets assocs init math ;
IN: destructors
SYMBOL: disposables
[ H{ } clone disposables set-global ] "destructors" add-init-hook
+ERROR: already-unregistered disposable ;
+
+SYMBOL: debug-leaks?
+
<PRIVATE
+SLOT: continuation
+
: register-disposable ( obj -- )
+ debug-leaks? get [ continuation >>continuation ] when
disposables get conjoin ;
: unregister-disposable ( obj -- )
- disposables get delete-at ;
+ disposables get 2dup key? [ already-unregistered ] unless delete-at ;
PRIVATE>
-TUPLE: disposable < identity-tuple disposed id ;
+TUPLE: disposable < identity-tuple
+{ id integer }
+{ disposed boolean }
+continuation ;
M: disposable hashcode* nip id>> ;