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 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 M: object dispose
  44     dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
  45
  46 M: disposable dispose
  47     dup disposed>> [ drop ] [
  48         [ unregister-disposable ]
  49         [ call-next-method ]
  50         bi
  51     ] if ;
  52
  53 : dispose-each ( seq -- )
  54     [
  55         [ [ dispose ] curry [ , ] recover ] each
  56     ] { } make [ last rethrow ] unless-empty ;
  57
  58 : with-disposal ( object quot -- )
  59     over [ dispose ] curry [ ] cleanup ; inline
  60
  61 <PRIVATE
  62
  63 SYMBOL: always-destructors
  64
  65 SYMBOL: error-destructors
  66
  67 : do-always-destructors ( -- )
  68     always-destructors get <reversed> dispose-each ;
  69
  70 : do-error-destructors ( -- )
  71     error-destructors get <reversed> dispose-each ;
  72
  73 PRIVATE>
  74
  75 : &dispose ( disposable -- disposable )
  76     dup always-destructors get push ; inline
  77
  78 : |dispose ( disposable -- disposable )
  79     dup error-destructors get push ; inline
  80
  81 : with-destructors ( quot -- )
  82     [
  83         V{ } clone always-destructors set
  84         V{ } clone error-destructors set
  85         [ do-always-destructors ]
  86         [ do-error-destructors ]
  87         cleanup
  88     ] with-scope ; inline
  89
  90 [
  91     H{ } clone disposables set-global
  92     V{ } clone always-destructors set-global
  93     V{ } clone error-destructors set-global
  94 ] "destructors" add-startup-hook
  95
  96 [
  97     do-always-destructors
  98     do-error-destructors
  99 ] "destructors" add-shutdown-hook