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 [ continuation >>continuation ] when
  21     disposables get conjoin ;
  22
  23 : unregister-disposable ( obj -- )
  24     disposables get 2dup key? [ already-unregistered ] unless delete-at ;
  25
  26 PRIVATE>
  27
  28 TUPLE: disposable < identity-tuple
  29 { id integer }
  30 { disposed boolean }
  31 continuation ;
  32
  33 M: disposable hashcode* nip id>> ;
  34
  35 : new-disposable ( class -- disposable )
  36     new \ disposable counter >>id
  37     dup register-disposable ; inline
  38
  39 GENERIC: dispose* ( disposable -- )
  40
  41 ERROR: already-disposed disposable ;
  42
  43 : check-disposed ( disposable -- )
  44     dup disposed>> [ already-disposed ] [ drop ] if ; inline
  45
  46 GENERIC: dispose ( disposable -- )
  47
  48 M: object dispose
  49     dup disposed>> [ drop ] [ t >>disposed dispose* ] if ;
  50
  51 M: disposable dispose
  52     [ unregister-disposable ] [ call-next-method ] bi ;
  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