Redo destructors so they compile

Fix all uses of add-destructor
release
U-C4\Administrator 2007-10-15 15:01:55 -05:00
parent 4192413861
commit ceba5efb1f
11 changed files with 174 additions and 68 deletions

View File

@ -1,25 +1,31 @@
USING: help.markup help.syntax kernel destructors ;
USING: help.markup help.syntax libc kernel destructors ;
IN: destructors
HELP: add-destructor
{ $values { "obj" "an object" }
{ "quot" "a quotation" }
{ "always?" "always cleanup?" }
} { $description "Adds a destructor to be invoked by the " { $link call-destructors } " word to the current dynamic scope. Setting the 'always cleanup?' flag to f allows for keeping resources, such as a successfully opened file descriptor, open after a call to " { $link with-destructors } "." }
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." $nl
"Destructors are not allowed to throw exceptions. No exceptions." }
{ $see-also call-destructors with-destructors } ;
HELP: free-always
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
{ $see-also free-later } ;
HELP: call-destructors
{ $description "Iterates through a sequence of destructor tuples, calling the destructor quotation on each one." }
{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." }
{ $see-also add-destructor with-destructors } ;
HELP: free-later
{ $values { "alien" "alien returned by malloc" } }
{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
{ $see-also free-always } ;
HELP: close-always
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
{ $see-also close-later } ;
HELP: close-later
{ $values { "handle" "an OS-dependent handle" } }
{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
{ $see-also close-always } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by calling " { $link add-destructor } ". After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link (destruct) } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc dup [ free \"free 10 bytes\" print ] t add-destructor drop ] with-destructors" }
{ $code "[ 10 malloc free-always ] with-destructors" }
}
{ $see-also add-destructor call-destructors } ;
{ $see-also } ;

View File

@ -3,27 +3,39 @@ IN: temporary
TUPLE: dummy-obj destroyed? ;
TUPLE: dummy-destructor ;
: <dummy-destructor> ( obj ? -- newobj )
<destructor> dummy-destructor construct-delegate ;
M: dummy-destructor (destruct) ( obj -- )
destructor-obj t swap set-dummy-obj-destroyed? ;
: <dummy-obj>
\ dummy-obj construct-empty ;
: destroy-always
t <dummy-destructor> push-destructor ;
: destroy-later
f <dummy-destructor> push-destructor ;
[ t ] [
[
<dummy-obj>
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
<dummy-obj> dup destroy-always
] with-destructors dummy-obj-destroyed?
] unit-test
[ f ] [
[
<dummy-obj>
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
<dummy-obj> dup destroy-later
] with-destructors dummy-obj-destroyed?
] unit-test
[ t ] [
<dummy-obj> [
[
dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
dup destroy-always
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
@ -32,7 +44,7 @@ TUPLE: dummy-obj destroyed? ;
[ t ] [
<dummy-obj> [
[
dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
dup destroy-later
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?

92
extra/destructors/destructors.factor Normal file → Executable file
View File

@ -1,38 +1,94 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations kernel namespaces sequences vectors ;
USING: continuations io.backend libc kernel namespaces
sequences system vectors ;
IN: destructors
SYMBOL: destructors
SYMBOL: errored?
TUPLE: destructor obj quot always? ;
<PRIVATE
TUPLE: destructor obj always? destroyed? ;
: filter-destructors ( -- )
errored? get [
destructors [ [ destructor-always? ] subset ] change
] unless ;
: <destructor> ( obj always? -- newobj )
{
set-destructor-obj
set-destructor-always?
} destructor construct ;
PRIVATE>
: push-destructor ( obj -- )
destructors [ ?push ] change ;
: add-destructor ( obj quot always? -- )
\ destructor construct-boa destructors [ ?push ] change ;
GENERIC: (destruct) ( obj -- )
: call-destructors ( -- )
destructors get [
dup destructor-obj swap destructor-quot call
] each ;
: 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 ] [ errored? on ] recover
filter-destructors call-destructors
errored? get [ rethrow ] when
[ 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 ;
USE-IF: windows? destructors.windows
USE-IF: unix? destructors.unix
! : add-destructor ( word quot -- )
! >quotation
! "slot-destructor" set-word-prop ;

View File

@ -0,0 +1,9 @@
USING: destructors io.windows kernel qualified ;
QUALIFIED: unix
IN: detructors.unix
M: unix-io (handle-destructor) ( obj -- )
destructor-obj close drop ;

View File

@ -0,0 +1,11 @@
USING: destructors io.windows kernel windows.kernel32
windows.winsock ;
IN: detructors.windows
M: windows-io (handle-destructor) ( obj -- )
destructor-obj CloseHandle drop ;
M: windows-io (socket-destructor) ( obj -- )
destructor-obj closesocket drop ;

View File

@ -50,7 +50,7 @@ C: <sniffer-spec> sniffer-spec
: make-ifreq-props ( ifname -- ifreq )
"ifreq" <c-object>
12 <short> 16 0 pad-right over set-ifreq-props
swap malloc-char-string dup [ free ] t add-destructor
swap malloc-char-string dup free-always
over set-ifreq-name ;
: make-ioctl-buffer ( fd -- buffer )
@ -77,7 +77,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
[
sniffer-spec-path
open-read
dup [ unix:close ] f add-destructor
dup close-later
] keep
dupd sniffer-spec-ifname ioctl-sniffer-fd
dup make-ioctl-buffer

30
extra/io/windows/launcher/launcher.factor Normal file → Executable file
View File

@ -1,7 +1,10 @@
USING: alien alien.c-types destructors io.windows libc
USING: alien alien.c-types arrays continuations
destructors io.windows libc
io.nonblocking io.streams.duplex windows.types math
windows.kernel32 windows namespaces io.launcher kernel
io.windows.nt.backend ;
sequences io.windows.nt.backend windows.errors ;
USE: io
USE: prettyprint
IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
@ -88,35 +91,44 @@ C: <pipe> pipe
: ERROR_PIPE_CONNECT 535 ; inline
: pipe-connect-error? ( n -- ? )
ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
! clear "ls" <process-stream> contents
M: windows-nt-io <process-stream> ( command -- stream )
[
break
default-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
! over set-CreateProcess-args-stdin-pipe
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
factor-pipe-name create-named-pipe
global [ "Named pipe: " write dup . ] bind
dup t set-inherit
[ add-completion ] keep
! CreateFile
! factor-pipe-name open-pipe-r/w
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f CreateFile dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
CreateFile
global [ "Created File: " write dup . ] bind
dup invalid-handle? dup close-later
dup add-completion
swap (make-overlapped) ConnectNamedPipe zero? [
GetLastError ERROR_PIPE_CONNECT = [
GetLastError pipe-connect-error? [
win32-error-string throw
] unless
] when
] when
dup t set-inherit
! ERROR_PIPE_CONNECTED
[ pick set-CreateProcess-args-stdin-pipe ] keep
global [ "Setting the stdios to: " write dup . ] bind
[ over set-STARTUPINFO-hStdOutput ] keep
[ over set-STARTUPINFO-hStdInput ] keep
swap set-STARTUPINFO-hStdError
@ -134,7 +146,7 @@ M: windows-nt-io <process-stream> ( command -- stream )
0
CreatePipe win32-error=0/f
] 2keep
[ *void* dup [ CloseHandle ] f add-destructor ] 2apply <pipe> ;
[ *void* dup close-later ] 2apply <pipe> ;
M: windows-ce-io <process-stream>
[

View File

@ -31,7 +31,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
"TOKEN_PRIVILEGES" <c-object>
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
"LUID_AND_ATTRIBUTES" malloc-array
dup [ free ] t add-destructor over set-TOKEN_PRIVILEGES-Privileges
dup free-always over set-TOKEN_PRIVILEGES-Privileges
swap [
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
@ -60,10 +60,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
dup [ CloseHandle drop ] f add-destructor
dup close-later
dup
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
dup [ CloseHandle drop ] f add-destructor
dup close-later
] with-privileges ;
M: windows-io <mapped-file> ( path length -- mmap )
@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
M: windows-io close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [
[ CloseHandle drop ] t add-destructor
close-always
] each
mapped-file-address UnmapViewOfFile win32-error=0/f
] with-destructors ;

2
extra/io/windows/nt/backend/backend.factor Normal file → Executable file
View File

@ -40,7 +40,7 @@ TUPLE: io-callback port continuation ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
"OVERLAPPED" malloc-object dup [ free ] t add-destructor
"OVERLAPPED" malloc-object dup free-always
0 over set-OVERLAPPED-internal
0 over set-OVERLAPPED-internal-high
0 over set-OVERLAPPED-offset-high

20
extra/io/windows/nt/sockets/sockets.factor Normal file → Executable file
View File

@ -81,7 +81,7 @@ TUPLE: AcceptEx-args port
: init-accept-buffer ( server-port AcceptEx -- )
>r server-port-addr sockaddr-type heap-size 16 +
dup dup 2 * malloc dup [ free ] t add-destructor r>
dup dup 2 * malloc dup free-always r>
[ set-AcceptEx-args-lpOutputBuffer* ] keep
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
set-AcceptEx-args-dwRemoteAddressLength* ;
@ -174,17 +174,17 @@ TUPLE: WSARecvFrom-args port
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
2dup >r malloc dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFrom*
>r malloc-int dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFromLen*
2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
>r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
] keep
"WSABUF" malloc-object dup [ free ] t add-destructor
"WSABUF" malloc-object dup free-always
2dup swap set-WSARecvFrom-args-lpBuffers*
default-buffer-size [ malloc dup [ free ] t add-destructor ] keep
default-buffer-size [ malloc dup free-always ] keep
pick set-WSABUF-len
swap set-WSABUF-buf
1 over set-WSARecvFrom-args-dwBufferCount*
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpFlags*
0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
(make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
swap WSARecvFrom-args-port set-port-overlapped ;
@ -230,14 +230,14 @@ TUPLE: WSASendTo-args port
set-WSASendTo-args-s*
] keep [
>r make-sockaddr >r
malloc-byte-array dup [ free ] t add-destructor
malloc-byte-array dup free-always
r> heap-size r>
[ set-WSASendTo-args-iToLen* ] keep
set-WSASendTo-args-lpTo*
] keep [
"WSABUF" malloc-object dup [ free ] t add-destructor
"WSABUF" malloc-object dup free-always
dup rot set-WSASendTo-args-lpBuffers*
swap [ malloc-byte-array dup [ free ] t add-destructor ] keep length
swap [ malloc-byte-array dup free-always ] keep length
rot [ set-WSABUF-len ] keep
set-WSABUF-buf
] keep

View File

@ -48,7 +48,7 @@ M: win32-file init-handle ( handle -- ) drop ;
: open-file ( path access-mode create-mode -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
@ -168,7 +168,7 @@ USE: windows.winsock
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket
dup [ closesocket drop ] f add-destructor
dup close-socket-later
dup rot make-sockaddr heap-size bind socket-error ;
USE: namespaces