Merge branch 'master' of git://factorcode.org/git/factor

core/debugger/debugger.factor

@@ -7,7 +7,7 @@ splitting math.parser classes.tuple continuations
 continuations.private combinators generic.math
 classes.builtin classes compiler.units generic.standard vocabs
 threads threads.private init kernel.private libc io.encodings
-mirrors accessors math.order ;
+mirrors accessors math.order destructors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -300,6 +300,8 @@ M: bad-create summary drop "Bad parameters to create" ;
 
 M: attempt-all-error summary drop "Nothing to attempt" ;
 
+M: already-disposed summary drop "Attempting to operate on disposed object" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

extra/cocoa/application/application-docs.factor

@@ -27,8 +27,8 @@ HELP: with-cocoa
 { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
 
 HELP: do-event
-{ $values { "app" "an " { $snippet "NSApplication" } } }
+{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
-{ $description "Processes any pending events in the queue. Does not block." } ;
+{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
 
 HELP: add-observer
 { $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }

extra/http/http-tests.factor

@@ -176,11 +176,11 @@ test-db [
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
-
-        yield
     ] with-scope
 ] unit-test
 
+[ ] [ 100 sleep ] unit-test
+
 [ t ] [
     "resource:extra/http/test/foo.html" ascii file-contents
     "http://localhost:1237/nested/foo.html" http-get =
@@ -222,7 +222,7 @@ test-db [
     ] with-scope
 ] unit-test
 
-[ ] [ 1000 sleep ] unit-test
+[ ] [ 100 sleep ] unit-test
 
 : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 
@@ -249,7 +249,7 @@ test-db [
     ] with-scope
 ] unit-test
 
-[ ] [ 1000 sleep ] unit-test
+[ ] [ 100 sleep ] unit-test
 
 [ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
 

extra/io/mmap/mmap-tests.factor

@@ -8,8 +8,3 @@ IN: io.mmap.tests
 [ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
 [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
 [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
-
-[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
-[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
-[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
-[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

extra/io/monitors/monitors-tests.factor

@@ -89,5 +89,6 @@ os { winnt linux macosx } member? [
     ] with-monitors
 
     ! Out-of-scope disposal should not fail
-    [ "" resource-path t <monitor> ] with-monitors dispose
+    [ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test
+    [ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test
 ] when

extra/io/ports/ports-docs.factor

@@ -22,7 +22,6 @@ $nl
 { $subsection init-stdio }
 { $subsection io-multiplex }
 "Per-port native I/O protocol:"
-{ $subsection init-handle }
 { $subsection (wait-to-read) }
 { $subsection (wait-to-write) }
 "Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ;
@@ -46,10 +45,6 @@ HELP: input-port
 HELP: output-port
 { $class-description "The class of ports implementing the output stream protocol." } ;
 
-HELP: init-handle
-{ $values { "handle" "a native handle identifying an I/O resource" } }
-{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
-
 HELP: <port>
 { $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
 { $description "Creates a new " { $link port } " with no buffer." }

extra/io/ports/ports.factor

@@ -16,11 +16,8 @@ M: port timeout timeout>> ;
 
 M: port set-timeout (>>timeout) ;
 
-GENERIC: init-handle ( handle -- )
-
 : <port> ( handle class -- port )
-    new
+    new swap >>handle ; inline
-        swap dup init-handle >>handle ; inline
 
 : pending-error ( port -- )
     [ f ] change-error drop [ throw ] when* ;
@@ -113,8 +110,7 @@ HOOK: (wait-to-write) io-backend ( port -- )
     dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
 
 M: output-port stream-flush ( port -- )
-    dup check-disposed
+    [ check-disposed ] [ flush-port ] bi ;
-    [ flush-port ] [ pending-error ] bi ;
 
 M: output-port dispose*
     [ flush-port ] [ call-next-method ] bi ;

extra/io/sockets/sockets-docs.factor

@@ -130,7 +130,7 @@ HELP: <server>
 { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
 
 HELP: accept
-{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
+{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "remote" "an address specifier" } }
 { $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
 { $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
 

extra/io/sockets/sockets-tests.factor

@@ -1,5 +1,6 @@
 IN: io.sockets.tests
-USING: io.sockets sequences math tools.test ;
+USING: io.sockets sequences math tools.test namespaces accessors 
+kernel destructors ;
 
 [ B{ 1 2 3 4 } ]
 [ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
@@ -44,3 +45,20 @@ USING: io.sockets sequences math tools.test ;
 [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
 
 [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
+
+! Smoke-test UDP
+[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram1" set ] unit-test
+[ ] [ "datagram1" get addr>> "addr1" set ] unit-test
+[ f ] [ "addr1" get port>> 0 = ] unit-test
+
+[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram2" set ] unit-test
+[ ] [ "datagram2" get addr>> "addr2" set ] unit-test
+[ f ] [ "addr2" get port>> 0 = ] unit-test
+
+[ ] [ B{ 1 2 3 4 } "addr2" get "datagram1" get send ] unit-test
+[ B{ 1 2 3 4 } ] [ "datagram2" get receive "from" set ] unit-test
+[ ] [ B{ 4 3 2 1 } "from" get "datagram2" get send ] unit-test
+[ B{ 4 3 2 1 } t ] [ "datagram1" get receive "addr2" get = ] unit-test
+
+[ ] [ "datagram1" get dispose ] unit-test
+[ ] [ "datagram2" get dispose ] unit-test

extra/io/sockets/sockets.factor

@@ -156,6 +156,11 @@ GENERIC: (get-local-address) ( handle remote -- sockaddr )
 : get-local-address ( handle remote -- local )
     [ (get-local-address) ] keep parse-sockaddr ;
 
+GENERIC: (get-remote-address) ( handle remote -- sockaddr )
+
+: get-remote-address ( handle local -- remote )
+    [ (get-remote-address) ] keep parse-sockaddr ;
+
 GENERIC: establish-connection ( client-out remote -- )
 
 GENERIC: ((client)) ( remote -- handle )
@@ -180,7 +185,7 @@ M: object (client) ( remote -- client-in client-out local )
 
 SYMBOL: local-address
 
-: with-client ( addrspec encoding quot -- )
+: with-client ( remote encoding quot -- )
     >r <client> [ local-address set ] curry
     r> compose with-stream ; inline
 
@@ -198,14 +203,14 @@ GENERIC: (server) ( addrspec -- handle )
     [ drop server-port <port> ] [ get-local-address ] 2bi
     >>addr r> >>encoding ;
 
-GENERIC: (accept) ( server addrspec -- handle )
+GENERIC: (accept) ( server addrspec -- handle sockaddr )
 
 : accept ( server -- client remote )
     [
         dup addr>>
         [ (accept) ] keep
-        [ drop dup <ports> ] [ get-local-address ] 2bi
+        parse-sockaddr swap
-        -rot
+        dup <ports>
     ] keep encoding>> <encoder-duplex> swap ;
 
 TUPLE: datagram-port < port addr ;
@@ -213,7 +218,11 @@ TUPLE: datagram-port < port addr ;
 HOOK: (datagram) io-backend ( addr -- datagram )
 
 : <datagram> ( addr -- datagram )
-    dup (datagram) datagram-port <port> swap >>addr ;
+    [
+        [ (datagram) |dispose ] keep
+        [ drop datagram-port <port> ] [ get-local-address ] 2bi
+        >>addr
+    ] with-destructors ;
 
 : check-datagram-port ( port -- port )
     dup check-disposed
@@ -221,7 +230,7 @@ HOOK: (datagram) io-backend ( addr -- datagram )
 
 HOOK: (receive) io-backend ( datagram -- packet addrspec )
 
-: receive ( datagram -- packet sockaddr )
+: receive ( datagram -- packet addrspec )
     check-datagram-port
     [ (receive) ] [ addr>> ] bi parse-sockaddr ;
 

extra/io/unix/backend/backend.factor

@@ -13,7 +13,15 @@ GENERIC: handle-fd ( handle -- fd )
 
 TUPLE: fd fd disposed ;
 
-: <fd> ( n -- fd ) f fd boa ;
+: <fd> ( n -- fd )
+    #! We drop the error code rather than calling io-error,
+    #! since on OS X 10.3, this operation fails from init-io
+    #! when running the Factor.app (presumably because fd 0 and
+    #! 1 are closed).
+    [ F_SETFL O_NONBLOCK fcntl drop ]
+    [ F_SETFD FD_CLOEXEC fcntl drop ]
+    [ f fd boa ]
+    tri ;
 
 M: fd dispose* fd>> close-file ;
 
@@ -48,11 +56,6 @@ M: mx remove-output-callbacks writes>> delete-at* drop ;
 
 GENERIC: wait-for-events ( ms mx -- )
 
-TUPLE: unix-io-error error port ;
-
-: report-error ( error port -- )
-    tuck unix-io-error boa >>error drop ;
-
 : input-available ( fd mx -- )
     remove-input-callbacks [ resume ] each ;
 
@@ -64,7 +67,7 @@ TUPLE: io-timeout ;
 M: io-timeout summary drop "I/O operation timed out" ;
 
 M: unix cancel-io ( port -- )
-    io-timeout new over report-error
+    io-timeout new >>error
     handle>> handle-fd mx get-global
     [ input-available ] [ output-available ] 2bi ;
 
@@ -101,15 +104,6 @@ SYMBOL: +output+
 
 : io-error ( n -- ) 0 < [ (io-error) ] when ;
  
-M: fd init-handle ( fd -- )
-    #! We drop the error code rather than calling io-error,
-    #! since on OS X 10.3, this operation fails from init-io
-    #! when running the Factor.app (presumably because fd 0 and
-    #! 1 are closed).
-    fd>>
-    [ F_SETFL O_NONBLOCK fcntl drop ]
-    [ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
-
 ! Readers
 : eof ( reader -- )
     dup buffer>> buffer-empty? [ t >>eof ] when drop ;

extra/io/unix/linux/monitors/monitors.factor

@@ -5,7 +5,7 @@ io.files io.buffers io.monitors io.ports io.timeouts
 io.unix.backend io.unix.select io.encodings.utf8
 unix.linux.inotify assocs namespaces threads continuations init
 math math.bitfields sets alien alien.strings alien.c-types
-vocabs.loader accessors system hashtables ;
+vocabs.loader accessors system hashtables destructors ;
 IN: io.unix.linux.monitors
 
 SYMBOL: watches
@@ -23,9 +23,9 @@ TUPLE: linux-monitor < monitor wd inotify watches disposed ;
 : wd>monitor ( wd -- monitor ) watches get at ;
 
 : <inotify> ( -- port/f )
-    inotify_init dup 0 < [ drop f ] [ <input-port> ] if ;
+    inotify_init dup 0 < [ drop f ] [ <fd> <input-port> ] if ;
 
-: inotify-fd inotify get handle>> ;
+: inotify-fd inotify get handle>> handle-fd ;
 
 : check-existing ( wd -- )
     watches get key? [
@@ -57,8 +57,10 @@ M: linux (monitor) ( path recursive? mailbox -- monitor )
 M: linux-monitor dispose* ( monitor -- )
     [ [ wd>> ] [ watches>> ] bi delete-at ]
     [
-        [ inotify>> handle>> ] [ wd>> ] bi
+        dup inotify>> disposed>> [ drop ] [
+            [ inotify>> handle>> handle-fd ] [ wd>> ] bi
             inotify_rm_watch io-error
+        ] if
     ] bi ;
 
 : ignore-flags? ( mask -- ? )
@@ -108,6 +110,7 @@ M: linux-monitor dispose* ( monitor -- )
     ] if ;
 
 : inotify-read-loop ( port -- )
+    dup check-disposed
     dup wait-to-read
     0 over buffer>> parse-file-notifications
     0 over buffer>> buffer-reset

extra/io/unix/pipes/pipes.factor

@@ -8,5 +8,4 @@ QUALIFIED: io.pipes
 M: unix io.pipes:(pipe) ( -- pair )
     2 "int" <c-array>
     dup pipe io-error
-    2 c-int-array> first2 [ <fd> ] bi@
+    2 c-int-array> first2 [ <fd> ] bi@ io.pipes:pipe boa ;
-    [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;

extra/io/unix/sockets/sockets.factor

@@ -13,7 +13,7 @@ EXCLUDE: io.sockets => accept ;
 IN: io.unix.sockets
 
 : socket-fd ( domain type -- fd )
-    0 socket dup io-error <fd> |dispose dup init-handle ;
+    0 socket dup io-error <fd> |dispose ;
 
 : set-socket-option ( fd level opt -- )
     >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
@@ -26,6 +26,10 @@ M: object (get-local-address) ( handle remote -- sockaddr )
     >r handle-fd r> empty-sockaddr/size <int>
     [ getsockname io-error ] 2keep drop ;
 
+M: object (get-remote-address) ( handle local -- sockaddr )
+    >r handle-fd r> empty-sockaddr/size <int>
+    [ getpeername io-error ] 2keep drop ;
+
 : init-client-socket ( fd -- )
     SOL_SOCKET SO_OOBINLINE set-socket-option ;
 
@@ -66,16 +70,17 @@ M: object (server) ( addrspec -- handle )
         dup handle-fd 10 listen io-error
     ] with-destructors ;
 
-: do-accept ( server addrspec -- fd )
+: do-accept ( server addrspec -- fd sockaddr )
-    [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi* accept ; inline
+    [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi*
+    [ accept ] 2keep drop ; inline
 
-M: object (accept) ( server addrspec -- fd )
+M: object (accept) ( server addrspec -- fd sockaddr )
     2dup do-accept
     {
-        { [ dup 0 >= ] [ 2nip <fd> ] }
+        { [ over 0 >= ] [ >r 2nip <fd> r> ] }
-        { [ err_no EINTR = ] [ drop (accept) ] }
+        { [ err_no EINTR = ] [ 2drop (accept) ] }
         { [ err_no EAGAIN = ] [
-            drop
+            2drop
             [ drop +input+ wait-for-port ]
             [ (accept) ]
             2bi

extra/io/windows/mmap/mmap-tests.factor

@@ -0,0 +1,8 @@
+USING: io io.mmap io.files kernel tools.test continuations
+sequences io.encodings.ascii accessors ;
+IN: io.windows.mmap.tests
+
+[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
+[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
+[ ] [ "mmap-grow-test.txt" temp-file 100 [ [ ] change-each ] with-mapped-file ] unit-test
+[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

extra/io/windows/nt/sockets/sockets.factor

@@ -82,17 +82,27 @@ TUPLE: AcceptEx-args port
     AcceptEx-args >tuple*< AcceptEx drop
     winsock-error-string [ throw ] when* ;
 
-M: object (accept) ( server addr -- handle )
+: extract-remote-address ( AcceptEx -- sockaddr )
-    [
+    {
+        [ lpOutputBuffer*>> ]
+        [ dwReceiveDataLength*>> ]
+        [ dwLocalAddressLength*>> ]
+        [ dwRemoteAddressLength*>> ]
+    } cleave
+    f <void*>
+    0 <int>
+    f <void*>
+    [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+
+M: object (accept) ( server addr -- handle sockaddr )
     [
         <AcceptEx-args>
         {
             [ call-AcceptEx ]
             [ wait-for-socket drop ]
-                [ sAcceptSocket*>> opened-socket ]
+            [ sAcceptSocket*>> <win32-socket> ]
-                [ port>> pending-error ]
+            [ extract-remote-address ]
         } cleave
-        ] curry with-timeout
     ] with-destructors ;
 
 TUPLE: WSARecvFrom-args port
@@ -126,12 +136,10 @@ TUPLE: WSARecvFrom-args port
 M: winnt (receive) ( datagram -- packet addrspec )
     [
         <WSARecvFrom-args>
-        {
         [ call-WSARecvFrom ]
         [ wait-for-socket ]
-            [ port>> pending-error ]
         [ parse-WSARecvFrom ]
-        } cleave
+        tri
     ] with-destructors ;
 
 TUPLE: WSASendTo-args port
@@ -166,6 +174,5 @@ M: winnt (send) ( packet addrspec datagram -- )
         <WSASendTo-args>
         [ call-WSASendTo ]
         [ wait-for-socket drop ]
-        [ port>> pending-error ]
+        bi
-        tri
     ] with-destructors ;

extra/io/windows/sockets/sockets.factor

@@ -30,6 +30,10 @@ M: object (get-local-address) ( socket addrspec -- sockaddr )
     >r handle>> r> empty-sockaddr/size <int>
     [ getsockname socket-error ] 2keep drop ;
 
+M: object (get-remote-address) ( socket addrspec -- sockaddr )
+    >r handle>> r> empty-sockaddr/size <int>
+    [ getpeername socket-error ] 2keep drop ;
+
 : bind-socket ( win32-socket sockaddr len -- )
     >r >r handle>> r> r> bind socket-error ;
 

extra/io/windows/windows.factor

@@ -24,9 +24,6 @@ TUPLE: win32-file < win32-handle ptr ;
 : <win32-file> ( handle -- win32-file )
     win32-file new-win32-handle ;
 
-M: win32-file init-handle ( handle -- )
-    drop ;
-
 HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )

extra/openssl/openssl.factor

@@ -133,8 +133,6 @@ M: no-ssl-context summary
     current-ssl-context handle>> SSL_new dup ssl-error
     f f ssl-handle boa ;
 
-M: ssl-handle init-handle file>> init-handle ;
-
 HOOK: ssl-shutdown io-backend ( handle -- )
 
 M: ssl-handle dispose*

extra/windows/winsock/winsock.factor

@@ -168,6 +168,7 @@ FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
 
 FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
+FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
 
 TYPEDEF: uint SERVICETYPE
 TYPEDEF: OVERLAPPED WSAOVERLAPPED