128 lines
3.0 KiB
Factor
Executable File
128 lines
3.0 KiB
Factor
Executable File
! Copyright (C) 2007 Doug Coleman.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: continuations io.backend libc kernel namespaces
|
|
sequences system vectors ;
|
|
IN: destructors
|
|
|
|
SYMBOL: destructors
|
|
|
|
TUPLE: destructor obj always? destroyed? ;
|
|
|
|
: <destructor> ( obj always? -- newobj )
|
|
{
|
|
set-destructor-obj
|
|
set-destructor-always?
|
|
} destructor construct ;
|
|
|
|
: push-destructor ( obj -- )
|
|
destructors [ ?push ] change ;
|
|
|
|
GENERIC: (destruct) ( obj -- )
|
|
|
|
: destruct ( obj -- )
|
|
dup destructor-destroyed? [
|
|
drop
|
|
] [
|
|
[ (destruct) t ] keep set-destructor-destroyed?
|
|
] if ;
|
|
|
|
: destruct-always ( destructor -- )
|
|
dup destructor-always? [
|
|
destruct
|
|
] [
|
|
drop
|
|
] if ;
|
|
|
|
: with-destructors ( quot -- )
|
|
[
|
|
[ call ]
|
|
[ destructors get [ destruct-always ] each ]
|
|
[ destructors get [ destruct ] each ] cleanup
|
|
] with-scope ; inline
|
|
|
|
|
|
|
|
TUPLE: memory-destructor ;
|
|
|
|
: <memory-destructor> ( obj ? -- newobj )
|
|
<destructor> memory-destructor construct-delegate ;
|
|
|
|
TUPLE: handle-destructor ;
|
|
|
|
: <handle-destructor> ( obj ? -- newobj )
|
|
<destructor> handle-destructor construct-delegate ;
|
|
|
|
TUPLE: socket-destructor ;
|
|
|
|
: <socket-destructor> ( obj ? -- newobj )
|
|
<destructor> socket-destructor construct-delegate ;
|
|
|
|
M: memory-destructor (destruct) ( obj -- )
|
|
destructor-obj free ;
|
|
|
|
HOOK: (handle-destructor) io-backend ( obj -- )
|
|
HOOK: (socket-destructor) io-backend ( obj -- )
|
|
|
|
M: handle-destructor (destruct) ( obj -- ) (handle-destructor) ;
|
|
M: socket-destructor (destruct) ( obj -- ) (socket-destructor) ;
|
|
|
|
: free-always ( alien -- )
|
|
t <memory-destructor> push-destructor ;
|
|
|
|
: free-later ( alien -- )
|
|
f <memory-destructor> push-destructor ;
|
|
|
|
: close-always ( handle -- )
|
|
t <handle-destructor> push-destructor ;
|
|
|
|
: close-later ( handle -- )
|
|
f <handle-destructor> push-destructor ;
|
|
|
|
: close-socket-always ( handle -- )
|
|
t <socket-destructor> push-destructor ;
|
|
|
|
: close-socket-later ( handle -- )
|
|
f <socket-destructor> push-destructor ;
|
|
|
|
|
|
! : add-destructor ( word quot -- )
|
|
! >quotation
|
|
! "slot-destructor" set-word-prop ;
|
|
|
|
! MACRO: destruct ( class -- )
|
|
! "slots" word-prop
|
|
! [ slot-spec-reader "slot-destructor" word-prop ] subset
|
|
! [
|
|
! [
|
|
! slot-spec-reader [ 1quotation ] keep
|
|
! "slot-destructor" word-prop [ when* ] curry compose
|
|
! [ keep f swap ] curry
|
|
! ] keep slot-spec-writer 1quotation compose
|
|
! dupd curry
|
|
! ] map concat nip ;
|
|
|
|
! : DTOR: scan-word parse-definition add-destructor ; parsing
|
|
|
|
! : free-destructor ( word -- )
|
|
! [ free ] add-destructor ;
|
|
|
|
! : stream-destructor ( word -- )
|
|
! [ stream-close ] add-destructor ;
|
|
|
|
|
|
! TUPLE: foo a b c ;
|
|
! C: <foo> foo
|
|
|
|
! DTOR: foo-a "lol, a destructor" print drop ;
|
|
! DTOR: foo-b "lol, b destructor" print drop ;
|
|
|
|
! TUPLE: stuff mem stream ;
|
|
! : <stuff>
|
|
! 100 malloc
|
|
! "license.txt" resource-path <file-reader>
|
|
! \ stuff construct-boa ;
|
|
|
|
! DTOR: stuff-mem free-destructor ;
|
|
! DTOR: stuff-stream stream-destructor ;
|
|
|