core/destructors/destructors.factor

   1 ! Copyright (C) 2007, 2010 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 ;
   5 FROM: namespaces => set ;
   6 IN: destructors
   7
   8 SYMBOL: disposables
   9
  10 ERROR: already-unregistered disposable ;
  11
  12 SYMBOL: debug-leaks?
  13
  14 <PRIVATE
  15
  16 SLOT: continuation
  17
  18 : register-disposable ( obj -- )
  19     debug-leaks? get-global [ continuation >>continuation ] when
  20     disposables get conjoin ;
  21
  22 : unregister-disposable ( obj -- )
  23     disposables get 2dup key? [ delete-at ] [ drop already-unregistered ] if ;
  24
  25 PRIVATE>
  26
  27 TUPLE: disposable < identity-tuple
  28 { disposed boolean }
  29 continuation ;
  30
  31 : new-disposable ( class -- disposable )
  32     new dup register-disposable ; inline
  33
  34 GENERIC: dispose* ( disposable -- )
  35
  36 ERROR: already-disposed disposable ;
  37
  38 : check-disposed ( disposable -- )
  39     dup disposed>> [ already-disposed ] [ drop ] if ; inline
  40
  41 GENERIC: dispose ( disposable -- )
  42
  43 : unless-disposed ( disposable quot -- )
  44     [ dup disposed>> [ drop ] ] dip if ; inline
  45
  46 M: object dispose [ t >>disposed dispose* ] unless-disposed ;
  47
  48 M: disposable dispose
  49     [
  50         [ unregister-disposable ]
  51         [ call-next-method ]
  52         bi
  53     ] unless-disposed ;
  54
  55 : dispose-each ( seq -- )
  56     [
  57         [ [ dispose ] curry [ , ] recover ] each
  58     ] { } make [ last rethrow ] unless-empty ;
  59
  60 : with-disposal ( object quot -- )
  61     over [ dispose ] curry [ ] cleanup ; inline
  62
  63 <PRIVATE
  64
  65 SYMBOL: always-destructors
  66
  67 SYMBOL: error-destructors
  68
  69 : do-always-destructors ( -- )
  70     always-destructors get <reversed> dispose-each ;
  71
  72 : do-error-destructors ( -- )
  73     error-destructors get <reversed> dispose-each ;
  74
  75 PRIVATE>
  76
  77 : &dispose ( disposable -- disposable )
  78     dup always-destructors get push ; inline
  79
  80 : |dispose ( disposable -- disposable )
  81     dup error-destructors get push ; inline
  82
  83 : with-destructors ( quot -- )
  84     [
  85         V{ } clone always-destructors set
  86         V{ } clone error-destructors set
  87         [ do-always-destructors ]
  88         [ do-error-destructors ]
  89         cleanup
  90     ] with-scope ; inline
  91
  92 [
  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
  97
  98 [
  99     do-always-destructors
 100     do-error-destructors
 101 ] "destructors" add-shutdown-hook