core/destructors/destructors.factor

   1 ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs continuations kernel namespaces
   4 sequences sets ;
   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 [ current-continuation >>continuation ] when
  19     disposables get adjoin ;
  20
  21 : unregister-disposable ( obj -- )
  22     dup disposables get ?delete [ 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 -- disposable )
  38     dup disposed>> [ already-disposed ] when ; inline
  39
  40 GENERIC: dispose ( disposable -- )
  41
  42 : unless-disposed ( disposable quot -- )
  43     [ dup disposed>> [ drop ] ] dip if ; inline
  44
  45 M: object dispose [ t >>disposed dispose* ] unless-disposed ;
  46
  47 M: disposable dispose
  48     [
  49         [ unregister-disposable ]
  50         [ call-next-method ]
  51         bi
  52     ] unless-disposed ;
  53
  54 : dispose-to ( obj accum -- )
  55     [ dispose ] [ push ] bi-curry* recover ; inline
  56
  57 : dispose-each ( seq -- )
  58     V{ } clone [ [ dispose-to ] curry each ] keep
  59     [ last rethrow ] unless-empty ;
  60
  61 : with-disposal ( object quot -- )
  62     over [ dispose ] curry finally ; inline
  63
  64 <PRIVATE
  65
  66 SYMBOL: always-destructors
  67
  68 SYMBOL: error-destructors
  69
  70 : do-always-destructors ( -- )
  71     always-destructors get <reversed> dispose-each ;
  72
  73 : do-error-destructors ( -- )
  74     error-destructors get <reversed> dispose-each ;
  75
  76 PRIVATE>
  77
  78 : &dispose ( disposable -- disposable )
  79     dup always-destructors get push ; inline
  80
  81 : |dispose ( disposable -- disposable )
  82     dup error-destructors get push ; inline
  83
  84 : with-destructors ( quot -- )
  85     H{ } clone
  86     V{ } clone always-destructors pick set-at
  87     V{ } clone error-destructors pick set-at [
  88         [ do-always-destructors ]
  89         [ do-error-destructors ]
  90         cleanup
  91     ] with-variables ; inline
  92
  93 STARTUP-HOOK: [
  94     HS{ } clone disposables set-global
  95     V{ } clone always-destructors set-global
  96     V{ } clone error-destructors set-global
  97 ]
  98
  99 SHUTDOWN-HOOK: [
 100     do-always-destructors
 101     do-error-destructors
 102 ]