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 ERROR: already-unregistered disposable ;
17 : register-disposable ( obj -- )
18 debug-leaks? get-global [ continuation >>continuation ] when
19 disposables get conjoin ;
21 : unregister-disposable ( obj -- )
22 disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
26 TUPLE: disposable < identity-tuple
30 : new-disposable ( class -- disposable )
31 new dup register-disposable ; inline
33 GENERIC: dispose* ( disposable -- )
35 ERROR: already-disposed disposable ;
37 : check-disposed ( disposable -- )
38 dup disposed>> [ already-disposed ] [ drop ] if ; inline
40 GENERIC: dispose ( disposable -- )
43 dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
46 dup disposed>> [ drop ] [
47 [ unregister-disposable ]
52 : dispose-each ( seq -- )
54 [ [ dispose ] curry [ , ] recover ] each
55 ] { } make [ last rethrow ] unless-empty ;
57 : with-disposal ( object quot -- )
58 over [ dispose ] curry [ ] cleanup ; inline
62 SYMBOL: always-destructors
64 SYMBOL: error-destructors
66 : do-always-destructors ( -- )
67 always-destructors get <reversed> dispose-each ;
69 : do-error-destructors ( -- )
70 error-destructors get <reversed> dispose-each ;
74 : &dispose ( disposable -- disposable )
75 dup always-destructors get push ; inline
77 : |dispose ( disposable -- disposable )
78 dup error-destructors get push ; inline
80 : with-destructors ( quot -- )
82 V{ } clone always-destructors set
83 V{ } clone error-destructors set
84 [ do-always-destructors ]
85 [ do-error-destructors ]
90 H{ } clone disposables set-global
91 V{ } clone always-destructors set-global
92 V{ } clone error-destructors set-global
93 ] "destructors" add-startup-hook
98 ] "destructors" add-shutdown-hook