core/destructors/destructors.factor

   1 ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
   2 ! See https://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 : if-disposed ( ..a disposable quot1: ( ..a -- ..b ) quot2: ( ..a disposable -- ..b ) -- ..b )
  41     [ dup disposed>> ] [ [ drop ] prepose ] [ ] tri* if ; inline
  42
  43 : when-disposed ( ..a disposable quot1: ( ..a -- ..b ) quot2: ( ..a disposable -- ..b ) -- ..b )
  44     [ ] if-disposed ; inline
  45
  46 : unless-disposed ( ... disposable quot: ( ... disposable -- ... ) -- ... )
  47     [ ] swap if-disposed ; inline
  48
  49 GENERIC: dispose ( disposable -- )
  50
  51 M: object dispose [ t >>disposed dispose* ] unless-disposed ;
  52
  53 M: disposable dispose
  54     [
  55         [ unregister-disposable ]
  56         [ call-next-method ]
  57         bi
  58     ] unless-disposed ;
  59
  60 : dispose-to ( obj accum -- )
  61     [ dispose ] [ push ] bi-curry* recover ; inline
  62
  63 : dispose-each ( seq -- )
  64     V{ } clone [ [ dispose-to ] curry each ] keep
  65     [ last rethrow ] unless-empty ;
  66
  67 : with-disposal ( object quot -- )
  68     over [ dispose ] curry finally ; inline
  69
  70 <PRIVATE
  71
  72 SYMBOL: always-destructors
  73
  74 SYMBOL: error-destructors
  75
  76 : do-always-destructors ( -- )
  77     always-destructors get <reversed> dispose-each ;
  78
  79 : do-error-destructors ( -- )
  80     error-destructors get <reversed> dispose-each ;
  81
  82 PRIVATE>
  83
  84 : &dispose ( disposable -- disposable )
  85     dup always-destructors get push ; inline
  86
  87 : |dispose ( disposable -- disposable )
  88     dup error-destructors get push ; inline
  89
  90 : with-destructors ( quot -- )
  91     H{ } clone
  92     V{ } clone always-destructors pick set-at
  93     V{ } clone error-destructors pick set-at [
  94         [ do-always-destructors ]
  95         [ do-error-destructors ]
  96         cleanup
  97     ] with-variables ; inline
  98
  99 STARTUP-HOOK: [
 100     HS{ } clone disposables set-global
 101     V{ } clone always-destructors set-global
 102     V{ } clone error-destructors set-global
 103 ]
 104
 105 SHUTDOWN-HOOK: [
 106     do-always-destructors
 107     do-error-destructors
 108 ]