1 ! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors continuations kernel namespaces make
4 sequences vectors sets assocs init math ;
9 [ H{ } clone disposables set-global ] "destructors" add-init-hook
11 ERROR: already-unregistered disposable ;
19 : register-disposable ( obj -- )
20 debug-leaks? get [ continuation >>continuation ] when
21 disposables get conjoin ;
23 : unregister-disposable ( obj -- )
24 disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
28 TUPLE: disposable < identity-tuple
33 M: disposable hashcode* nip id>> ;
35 : new-disposable ( class -- disposable )
36 new \ disposable counter >>id
37 dup register-disposable ; inline
39 GENERIC: dispose* ( disposable -- )
41 ERROR: already-disposed disposable ;
43 : check-disposed ( disposable -- )
44 dup disposed>> [ already-disposed ] [ drop ] if ; inline
46 GENERIC: dispose ( disposable -- )
49 dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
52 dup disposed>> [ drop ] [
53 [ unregister-disposable ]
58 : dispose-each ( seq -- )
60 [ [ dispose ] curry [ , ] recover ] each
61 ] { } make [ last rethrow ] unless-empty ;
63 : with-disposal ( object quot -- )
64 over [ dispose ] curry [ ] cleanup ; inline
68 SYMBOL: always-destructors
70 SYMBOL: error-destructors
72 : do-always-destructors ( -- )
73 always-destructors get <reversed> dispose-each ;
75 : do-error-destructors ( -- )
76 error-destructors get <reversed> dispose-each ;
80 : &dispose ( disposable -- disposable )
81 dup always-destructors get push ; inline
83 : |dispose ( disposable -- disposable )
84 dup error-destructors get push ; inline
86 : with-destructors ( quot -- )
88 V{ } clone always-destructors set
89 V{ } clone error-destructors set
90 [ do-always-destructors ]
91 [ do-error-destructors ]