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 { 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     dup disposed>> [ drop ] [
  53         [ unregister-disposable ]
  54         [ call-next-method ]
  55         bi
  56     ] if ;
  57
  58 : dispose-each ( seq -- )
  59     [
  60         [ [ dispose ] curry [ , ] recover ] each
  61     ] { } make [ last rethrow ] unless-empty ;
  62
  63 : with-disposal ( object quot -- )
  64     over [ dispose ] curry [ ] cleanup ; inline
  65
  66 <PRIVATE
  67
  68 SYMBOL: always-destructors
  69
  70 SYMBOL: error-destructors
  71
  72 : do-always-destructors ( -- )
  73     always-destructors get <reversed> dispose-each ;
  74
  75 : do-error-destructors ( -- )
  76     error-destructors get <reversed> dispose-each ;
  77
  78 PRIVATE>
  79
  80 : &dispose ( disposable -- disposable )
  81     dup always-destructors get push ; inline
  82
  83 : |dispose ( disposable -- disposable )
  84     dup error-destructors get push ; inline
  85
  86 : with-destructors ( quot -- )
  87     [
  88         V{ } clone always-destructors set
  89         V{ } clone error-destructors set
  90         [ do-always-destructors ]
  91         [ do-error-destructors ]
  92         cleanup
  93     ] with-scope ; inline