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 ;
9 ERROR: already-unregistered disposable ;
17 : register-disposable ( obj -- )
18 debug-leaks? get-global [ current-continuation >>continuation ] when
19 disposables get adjoin ;
21 : unregister-disposable ( obj -- )
22 disposables get 2dup in? [ delete ] [ drop throw-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 -- disposable )
38 dup disposed>> [ already-disposed ] when ; inline
40 GENERIC: dispose ( disposable -- )
42 : unless-disposed ( disposable quot -- )
43 [ dup disposed>> [ drop ] ] dip if ; inline
45 M: object dispose [ t >>disposed dispose* ] unless-disposed ;
49 [ unregister-disposable ]
54 : dispose-to ( obj accum -- )
55 [ dispose ] [ push ] bi-curry* recover ; inline
57 : dispose-each ( seq -- )
58 V{ } clone [ [ dispose-to ] curry each ] keep
59 [ last rethrow ] unless-empty ;
61 : with-disposal ( object quot -- )
62 over [ dispose ] curry [ ] cleanup ; inline
66 SYMBOL: always-destructors
68 SYMBOL: error-destructors
70 : do-always-destructors ( -- )
71 always-destructors get <reversed> dispose-each ;
73 : do-error-destructors ( -- )
74 error-destructors get <reversed> dispose-each ;
78 : &dispose ( disposable -- disposable )
79 dup always-destructors get push ; inline
81 : |dispose ( disposable -- disposable )
82 dup error-destructors get push ; inline
84 : with-destructors ( quot -- )
86 V{ } clone always-destructors set
87 V{ } clone error-destructors set
88 [ do-always-destructors ]
89 [ do-error-destructors ]
94 HS{ } clone disposables set-global
95 V{ } clone always-destructors set-global
96 V{ } clone error-destructors set-global
97 ] "destructors" add-startup-hook
100 do-always-destructors
102 ] "destructors" add-shutdown-hook