tools.destructors: destructors. and leaks words now output a 'show instances' link which lists all relevant disposables

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
 
 <PRIVATE
 
-: disposable-tally ( -- assoc )
+: class-tally ( assoc -- assoc' )
-    disposables get
+    H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ;
-    H{ } clone [ [ keys ] dip '[ class _ inc-at ] each ] keep ;
-
-: subtract-values ( assoc1 assoc2 -- assoc )
-    [ [ keys ] bi@ append prune ] 2keep
-    H{ } clone [
-        '[
-            [ _ _ [ at 0 or ] bi-curry@ bi - ] keep _ set-at
-        ] each
-    ] keep ;
 
 : (disposables.) ( assoc -- )
-    >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<sequence
+            ] with-row
+        ] each
+    ] tabular-output nl ;
+
+: 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 get clone
-    (disposables.) ; inline
+    debug-leaks? on
+    [
+        [ call disposables get clone ] dip
+    ] [ ] [ debug-leaks? off ] cleanup
+     assoc-diff (disposables.) ; inline

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?
+
 <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>> ;