-! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors continuations kernel namespaces make
-sequences vectors sets assocs init math ;
+USING: accessors assocs continuations kernel namespaces
+sequences sets ;
IN: destructors
SYMBOL: disposables
-[ H{ } clone disposables set-global ] "destructors" add-startup-hook
-
ERROR: already-unregistered disposable ;
SYMBOL: debug-leaks?
SLOT: continuation
: register-disposable ( obj -- )
- debug-leaks? get-global [ continuation >>continuation ] when
- disposables get conjoin ;
+ debug-leaks? get-global [ current-continuation >>continuation ] when
+ disposables get adjoin ;
: unregister-disposable ( obj -- )
- disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
+ dup disposables get ?delete [ drop ] [ already-unregistered ] if ;
PRIVATE>
TUPLE: disposable < identity-tuple
-{ id integer }
{ disposed boolean }
continuation ;
-M: disposable hashcode* nip id>> ;
-
: new-disposable ( class -- disposable )
- new \ disposable counter >>id
- dup register-disposable ; inline
+ new dup register-disposable ; inline
GENERIC: dispose* ( disposable -- )
ERROR: already-disposed disposable ;
-: check-disposed ( disposable -- )
- dup disposed>> [ already-disposed ] [ drop ] if ; inline
+: check-disposed ( disposable -- disposable )
+ dup disposed>> [ already-disposed ] when ; inline
GENERIC: dispose ( disposable -- )
-M: object dispose
- dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
+: unless-disposed ( disposable quot -- )
+ [ dup disposed>> [ drop ] ] dip if ; inline
+
+M: object dispose [ t >>disposed dispose* ] unless-disposed ;
M: disposable dispose
- dup disposed>> [ drop ] [
+ [
[ unregister-disposable ]
[ call-next-method ]
bi
- ] if ;
+ ] unless-disposed ;
+
+: dispose-to ( obj accum -- )
+ [ dispose ] [ push ] bi-curry* recover ; inline
: dispose-each ( seq -- )
- [
- [ [ dispose ] curry [ , ] recover ] each
- ] { } make [ last rethrow ] unless-empty ;
+ V{ } clone [ [ dispose-to ] curry each ] keep
+ [ last rethrow ] unless-empty ;
: with-disposal ( object quot -- )
- over [ dispose ] curry [ ] cleanup ; inline
+ over [ dispose ] curry finally ; inline
<PRIVATE
dup error-destructors get push ; inline
: with-destructors ( quot -- )
- [
- V{ } clone always-destructors set
- V{ } clone error-destructors set
+ H{ } clone
+ V{ } clone always-destructors pick set-at
+ V{ } clone error-destructors pick set-at [
[ do-always-destructors ]
[ do-error-destructors ]
cleanup
- ] with-scope ; inline
-
-[
- [
- always-destructors get-global dispose-each
- error-destructors get-global dispose-each
- ] with-destructors
-] "destructors.global" add-shutdown-hook
+ ] with-variables ; inline
+
+STARTUP-HOOK: [
+ HS{ } clone disposables set-global
+ V{ } clone always-destructors set-global
+ V{ } clone error-destructors set-global
+]
+
+SHUTDOWN-HOOK: [
+ do-always-destructors
+ do-error-destructors
+]