1 ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs continuations init kernel make
4 namespaces sequences sets ;
5 FROM: namespaces => set ;
10 ERROR: already-unregistered disposable ;
18 : register-disposable ( obj -- )
19 debug-leaks? get-global [ current-continuation >>continuation ] when
20 disposables get conjoin ;
22 : unregister-disposable ( obj -- )
23 disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
27 TUPLE: disposable < identity-tuple
31 : new-disposable ( class -- disposable )
32 new dup register-disposable ; inline
34 GENERIC: dispose* ( disposable -- )
36 ERROR: already-disposed disposable ;
38 : check-disposed ( disposable -- )
39 dup disposed>> [ already-disposed ] [ drop ] if ; inline
41 GENERIC: dispose ( disposable -- )
43 : unless-disposed ( disposable quot -- )
44 [ dup disposed>> [ drop ] ] dip if ; inline
46 M: object dispose [ t >>disposed dispose* ] unless-disposed ;
50 [ unregister-disposable ]
55 : dispose-each ( seq -- )
57 [ [ dispose ] curry [ , ] recover ] each
58 ] { } make [ last rethrow ] unless-empty ;
60 : with-disposal ( object quot -- )
61 over [ dispose ] curry [ ] cleanup ; inline
65 SYMBOL: always-destructors
67 SYMBOL: error-destructors
69 : do-always-destructors ( -- )
70 always-destructors get <reversed> dispose-each ;
72 : do-error-destructors ( -- )
73 error-destructors get <reversed> dispose-each ;
77 : &dispose ( disposable -- disposable )
78 dup always-destructors get push ; inline
80 : |dispose ( disposable -- disposable )
81 dup error-destructors get push ; inline
83 : with-destructors ( quot -- )
85 V{ } clone always-destructors set
86 V{ } clone error-destructors set
87 [ do-always-destructors ]
88 [ do-error-destructors ]
93 H{ } clone disposables set-global
94 V{ } clone always-destructors set-global
95 V{ } clone error-destructors set-global
96 ] "destructors" add-startup-hook
101 ] "destructors" add-shutdown-hook