core/destructors/destructors.factor

   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 ;
   5 IN: destructors
   6
   7 SYMBOL: disposables
   8
   9 [ H{ } clone disposables set-global ] "destructors" add-init-hook
  10
  11 <PRIVATE
  12
  13 : register-disposable ( obj -- )
  14     disposables get conjoin ;
  15
  16 : unregister-disposable ( obj -- )
  17     disposables get delete-at ;
  18
  19 PRIVATE>
  20
  21 TUPLE: disposable < identity-tuple disposed id ;
  22
  23 M: disposable hashcode* nip id>> ;
  24
  25 : new-disposable ( class -- disposable )
  26     new \ disposable counter >>id
  27     dup register-disposable ; inline
  28
  29 GENERIC: dispose* ( disposable -- )
  30
  31 ERROR: already-disposed disposable ;
  32
  33 : check-disposed ( disposable -- )
  34     dup disposed>> [ already-disposed ] [ drop ] if ; inline
  35
  36 GENERIC: dispose ( disposable -- )
  37
  38 M: object dispose
  39     dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
  40
  41 M: disposable dispose
  42     [ unregister-disposable ] [ call-next-method ] bi ;
  43
  44 : dispose-each ( seq -- )
  45     [
  46         [ [ dispose ] curry [ , ] recover ] each
  47     ] { } make [ last rethrow ] unless-empty ;
  48
  49 : with-disposal ( object quot -- )
  50     over [ dispose ] curry [ ] cleanup ; inline
  51
  52 <PRIVATE
  53
  54 SYMBOL: always-destructors
  55
  56 SYMBOL: error-destructors
  57
  58 : do-always-destructors ( -- )
  59     always-destructors get <reversed> dispose-each ;
  60
  61 : do-error-destructors ( -- )
  62     error-destructors get <reversed> dispose-each ;
  63
  64 PRIVATE>
  65
  66 : &dispose ( disposable -- disposable )
  67     dup always-destructors get push ; inline
  68
  69 : |dispose ( disposable -- disposable )
  70     dup error-destructors get push ; inline
  71
  72 : with-destructors ( quot -- )
  73     [
  74         V{ } clone always-destructors set
  75         V{ } clone error-destructors set
  76         [ do-always-destructors ]
  77         [ do-error-destructors ]
  78         cleanup
  79     ] with-scope ; inline