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