diff --git a/basis/tools/destructors/destructors.factor b/basis/tools/destructors/destructors.factor index 4f182c6777..d032b5291a 100644 --- a/basis/tools/destructors/destructors.factor +++ b/basis/tools/destructors/destructors.factor @@ -1,31 +1,51 @@ ! 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 alist sort-keys simple-table. ; + 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> ] 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 diff --git a/core/destructors/destructors.factor b/core/destructors/destructors.factor index 39f0e9f2b9..d306da18c4 100644 --- a/core/destructors/destructors.factor +++ b/core/destructors/destructors.factor @@ -1,24 +1,34 @@ ! 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? + >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>> ;