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 assocs continuations init kernel make
   4 namespaces sequences sets ;
   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 [ current-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, ( obj -- )
  56     [ dispose ] curry [ , ] recover ; inline
  57
  58 : dispose-each ( seq -- )
  59     [ [ dispose, ] each ] { } make
  60     [ last rethrow ] unless-empty ;
  61
  62 : with-disposal ( object quot -- )
  63     over [ dispose ] curry [ ] cleanup ; inline
  64
  65 <PRIVATE
  66
  67 SYMBOL: always-destructors
  68
  69 SYMBOL: error-destructors
  70
  71 : do-always-destructors ( -- )
  72     always-destructors get <reversed> dispose-each ;
  73
  74 : do-error-destructors ( -- )
  75     error-destructors get <reversed> dispose-each ;
  76
  77 PRIVATE>
  78
  79 : &dispose ( disposable -- disposable )
  80     dup always-destructors get push ; inline
  81
  82 : |dispose ( disposable -- disposable )
  83     dup error-destructors get push ; inline
  84
  85 : with-destructors ( quot -- )
  86     [
  87         V{ } clone always-destructors set
  88         V{ } clone error-destructors set
  89         [ do-always-destructors ]
  90         [ do-error-destructors ]
  91         cleanup
  92     ] with-scope ; inline
  93
  94 [
  95     H{ } clone disposables set-global
  96     V{ } clone always-destructors set-global
  97     V{ } clone error-destructors set-global
  98 ] "destructors" add-startup-hook
  99
 100 [
 101     do-always-destructors
 102     do-error-destructors
 103 ] "destructors" add-shutdown-hook