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