diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index ca475bf80a..aedad25906 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -64,3 +64,7 @@ cell 8 = [ [ 0 B{ 1 2 3 } alien-address ] unit-test-fails [ 1 1 ] unit-test-fails + +[ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test + +[ "( displaced alien )" ] [ 0 B{ 1 2 3 } unparse ] unit-test diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 564efd72df..32157dcb90 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -18,7 +18,7 @@ PREDICATE: alien pinned-alien underlying-alien pinned-c-ptr? ; UNION: pinned-c-ptr - alien POSTPONE: f ; + pinned-alien POSTPONE: f ; UNION: c-ptr alien bit-array byte-array float-array POSTPONE: f ; diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index ee2d8b309b..c988446e20 100644 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -68,3 +68,7 @@ TYPEDEF: int* MyIntArray TYPEDEF: uchar* MyLPBYTE [ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test + +[ + 0 B{ 1 2 3 4 } +] unit-test-fails diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index d204390d00..ed1520e9a1 100644 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -3,7 +3,7 @@ USING: arrays alien alien.c-types alien.structs kernel math namespaces parser sequences words quotations math.parser splitting effects prettyprint prettyprint.sections -prettyprint.backend assocs ; +prettyprint.backend assocs combinators ; IN: alien.syntax parsing M: alien pprint* - dup expired? [ - drop "( alien expired )" text - ] [ - \ ALIEN: [ alien-address pprint* ] pprint-prefix - ] if ; + { + { [ dup expired? ] [ drop "( alien expired )" text ] } + { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } + { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } + } cond ; M: dll pprint* dll-path dup "DLL\" " pprint-string ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 48ff041b6c..e9dc4f3e55 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -119,9 +119,10 @@ SYMBOL: load-help? "To define one, refer to \\ MAIN: help" print ] ?if ; -: modified ( assoc -- seq ) - [ nip dup [ source-modified? ] when ] assoc-subset - keys ; +: modified ( seq quot -- seq ) + [ dup ] swap compose { } map>assoc + [ nip ] assoc-subset + [ nip source-modified? ] assoc-subset keys ; inline : vocab-path+ ( vocab path -- newpath ) swap vocab-root dup [ swap path+ ] [ 2drop f ] if ; @@ -136,19 +137,26 @@ SYMBOL: load-help? dup vocab-docs vocab-path+ ; : modified-sources ( vocabs -- seq ) - [ dup vocab-source-path ] { } map>assoc modified ; + [ vocab-source-path ] modified ; : modified-docs ( vocabs -- seq ) - [ dup vocab-docs-path ] { } map>assoc modified ; + [ vocab-docs-path ] modified ; -: (refresh) ( prefix -- seq ) +: update-roots ( vocabs -- ) + [ dup find-vocab-root swap vocab set-vocab-root ] each ; + +: to-refresh ( prefix -- seq ) child-vocabs - dup modified-sources swap modified-docs 2dup + dup update-roots + dup modified-sources swap modified-docs ; + +: do-refresh ( modified-sources modified-docs -- ) + 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune dup [ [ require ] each ] no-parse-hook ; + append prune [ [ require ] each ] no-parse-hook ; -: refresh ( prefix -- ) (refresh) drop ; +: refresh ( prefix -- ) to-refresh do-refresh ; : refresh-all ( -- ) "" refresh ; diff --git a/core/bootstrap/help/authors.txt b/extra/bootstrap/help/authors.txt similarity index 100% rename from core/bootstrap/help/authors.txt rename to extra/bootstrap/help/authors.txt diff --git a/core/bootstrap/help/help.factor b/extra/bootstrap/help/help.factor similarity index 100% rename from core/bootstrap/help/help.factor rename to extra/bootstrap/help/help.factor diff --git a/core/bootstrap/help/summary.txt b/extra/bootstrap/help/summary.txt similarity index 100% rename from core/bootstrap/help/summary.txt rename to extra/bootstrap/help/summary.txt diff --git a/core/bootstrap/io/authors.txt b/extra/bootstrap/io/authors.txt similarity index 100% rename from core/bootstrap/io/authors.txt rename to extra/bootstrap/io/authors.txt diff --git a/core/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor similarity index 100% rename from core/bootstrap/io/io.factor rename to extra/bootstrap/io/io.factor diff --git a/core/bootstrap/io/summary.txt b/extra/bootstrap/io/summary.txt similarity index 100% rename from core/bootstrap/io/summary.txt rename to extra/bootstrap/io/summary.txt diff --git a/core/bootstrap/math/math.factor b/extra/bootstrap/math/math.factor similarity index 100% rename from core/bootstrap/math/math.factor rename to extra/bootstrap/math/math.factor diff --git a/core/bootstrap/math/summary.txt b/extra/bootstrap/math/summary.txt similarity index 100% rename from core/bootstrap/math/summary.txt rename to extra/bootstrap/math/summary.txt diff --git a/core/bootstrap/tools/authors.txt b/extra/bootstrap/tools/authors.txt similarity index 100% rename from core/bootstrap/tools/authors.txt rename to extra/bootstrap/tools/authors.txt diff --git a/core/bootstrap/tools/summary.txt b/extra/bootstrap/tools/summary.txt similarity index 100% rename from core/bootstrap/tools/summary.txt rename to extra/bootstrap/tools/summary.txt diff --git a/core/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor similarity index 100% rename from core/bootstrap/tools/tools.factor rename to extra/bootstrap/tools/tools.factor diff --git a/core/bootstrap/ui/authors.txt b/extra/bootstrap/ui/authors.txt similarity index 100% rename from core/bootstrap/ui/authors.txt rename to extra/bootstrap/ui/authors.txt diff --git a/core/bootstrap/ui/summary.txt b/extra/bootstrap/ui/summary.txt similarity index 100% rename from core/bootstrap/ui/summary.txt rename to extra/bootstrap/ui/summary.txt diff --git a/core/bootstrap/ui/tools/authors.txt b/extra/bootstrap/ui/tools/authors.txt similarity index 100% rename from core/bootstrap/ui/tools/authors.txt rename to extra/bootstrap/ui/tools/authors.txt diff --git a/core/bootstrap/ui/tools/summary.txt b/extra/bootstrap/ui/tools/summary.txt similarity index 100% rename from core/bootstrap/ui/tools/summary.txt rename to extra/bootstrap/ui/tools/summary.txt diff --git a/core/bootstrap/ui/tools/tools.factor b/extra/bootstrap/ui/tools/tools.factor similarity index 100% rename from core/bootstrap/ui/tools/tools.factor rename to extra/bootstrap/ui/tools/tools.factor diff --git a/core/bootstrap/ui/ui.factor b/extra/bootstrap/ui/ui.factor similarity index 100% rename from core/bootstrap/ui/ui.factor rename to extra/bootstrap/ui/ui.factor diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor old mode 100644 new mode 100755 index 6741732cc4..7231bb6402 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007 Slava Pestov, Doug Coleman +! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking USING: math kernel io sequences io.buffers generic sbufs system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays ; +continuations debugger classes byte-arrays namespaces ; -: default-buffer-size 64 1024 * ; inline +SYMBOL: default-buffer-size +64 1024 * default-buffer-size set-global ! Common delegate of native stream readers and writers TUPLE: port handle error timeout cutoff type eof? ; @@ -18,6 +19,7 @@ PREDICATE: port input-port port-type input eq? ; PREDICATE: port output-port port-type output eq? ; GENERIC: init-handle ( handle -- ) +GENERIC: close-handle ( handle -- ) : ( handle buffer -- port ) over init-handle @@ -29,7 +31,7 @@ GENERIC: init-handle ( handle -- ) } port construct ; : ( handle -- port ) - default-buffer-size ; + default-buffer-size get ; : ( handle -- stream ) input over set-port-type ; @@ -150,6 +152,20 @@ M: output-port stream-write1 M: output-port stream-write over length over wait-to-write >buffer ; +GENERIC: port-flush ( port -- ) + +M: output-port stream-flush ( port -- ) + dup port-flush pending-error ; + +M: port stream-close + dup port-type closed eq? [ + dup port-type >r closed over set-port-type r> + output eq? [ dup port-flush ] when + dup port-handle close-handle + dup delegate [ buffer-free ] when* + f over set-delegate + ] unless drop ; + TUPLE: server-port addr client ; : ( port addr -- server ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100644 new mode 100755 index a0d8658661..486fe46866 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -34,6 +34,9 @@ M: integer init-handle ( fd -- ) #! 1 are closed). F_SETFL O_NONBLOCK fcntl drop ; +M: integer close-handle ( fd -- ) + close ; + : report-error ( error port -- ) [ "Error on fd " % dup port-handle # ": " % swap % ] "" make swap set-port-error ; @@ -168,21 +171,9 @@ M: write-task task-container drop write-tasks get-global ; : (wait-to-write) ( port -- ) [ swap add-write-io-task stop ] callcc0 drop ; -: port-flush ( port -- ) +M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; -M: output-port stream-flush - dup port-flush pending-error ; - -M: port stream-close - dup port-type closed eq? [ - dup port-type >r closed over set-port-type r> - output eq? [ dup port-flush ] when - dup port-handle close - dup delegate [ buffer-free ] when* - f over set-delegate - ] unless drop ; - USE: io M: unix-io init-io ( -- ) diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor new file mode 100755 index 0000000000..37eb161ff8 --- /dev/null +++ b/extra/io/windows/ce/backend/backend.factor @@ -0,0 +1,42 @@ +USING: io.nonblocking io.windows threads.private kernel +io.backend windows.winsock windows.kernel32 windows +io.streams.duplex io namespaces alien.syntax system combinators ; +IN: io.windows.ce.backend + +: port-errored ( port -- ) + win32-error-string swap set-port-error ; + +M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; +M: windows-ce-io add-completion ( port -- ) drop ; + +GENERIC: wince-read ( port port-handle -- ) + +M: input-port (wait-to-read) ( port -- ) + dup port-handle wince-read ; + +GENERIC: wince-write ( port port-handle -- ) + +M: windows-ce-io flush-output ( port -- ) + dup port-handle wince-write ; + +M: windows-ce-io init-io ( -- ) + init-winsock ; + +LIBRARY: libc +FUNCTION: void* _getstdfilex int fd ; +FUNCTION: void* _fileno void* file ; + +M: windows-ce-io init-stdio ( -- ) + #! We support Windows NT too, to make this I/O backend + #! easier to debug. + 4096 default-buffer-size [ + winnt? [ + STD_INPUT_HANDLE GetStdHandle + STD_OUTPUT_HANDLE GetStdHandle + ] [ + 0 _getstdfilex _fileno + 1 _getstdfilex _fileno + ] if + >r f + r> f + ] with-variable stdio set ; diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor old mode 100644 new mode 100755 index b45f2df4d7..4c0237761e --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -1,235 +1,5 @@ -USING: alien alien.c-types combinators -io io.backend io.buffers io.files io.nonblocking io.sockets -io.sockets.impl io.windows kernel libc math namespaces -prettyprint qualified sequences strings threads threads.private -windows windows.kernel32 ; -QUALIFIED: windows.winsock +USING: io.backend io.windows io.windows.ce.backend +io.windows.ce.files io.windows.ce.sockets namespaces ; IN: io.windows.ce -! M: windows-ce-io normalize-pathname ( string -- string ) - ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; - -M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; -M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; -M: windows-ce-io io-multiplex ( ms -- ) (sleep) ; -M: windows-ce-io add-completion ( port -- ? ) drop f ; - -: port-errored ( port -- ) - win32-error-string swap set-port-error ; - -GENERIC: wince-read ( port port-handle -- ) - -M: win32-file wince-read - drop dup make-FileArgs dup setup-read ReadFile zero? [ - drop port-errored - ] [ - FileArgs-lpNumberOfBytesRet *uint dup zero? [ - drop - t swap set-port-eof? - ] [ - swap n>buffer - ] if - ] if ; - -TUPLE: WSAArgs - s - lpBuffers - dwBufferCount - lpNumberOfBytesRet - lpFlags - lpOverlapped - lpCompletionRoutine ; -C: WSAArgs - -: make-WSAArgs ( port -- ) - [ port-handle win32-file-handle ] keep - delegate 1 "DWORD" f f f ; - -: setup-WSARecv ( -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine ) - [ WSAArgs-s ] keep - [ - WSAArgs-lpBuffers [ buffer-capacity ] keep - buffer-end - "WSABUF" - [ windows.winsock:set-WSABUF-buf ] keep - [ windows.winsock:set-WSABUF-len ] keep - ] keep - [ WSAArgs-dwBufferCount ] keep - [ WSAArgs-lpNumberOfBytesRet ] keep - [ WSAArgs-lpFlags ] keep - [ WSAArgs-lpOverlapped ] keep - WSAArgs-lpCompletionRoutine ; - -! M: win32-socket wince-read ( port port-handle -- ) - ! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [ - ! drop port-errored - ! ] [ - ! WSAArgs-lpNumberOfBytesRet *uint dup zero? [ - ! drop - ! t swap set-port-eof? - ! ] [ - ! swap n>buffer - ! ] if - ! ] if ; - -M: win32-socket wince-read ( port port-handle -- ) - win32-file-handle over - delegate [ buffer-end ] keep buffer-capacity 0 - windows.winsock:recv dup windows.winsock:SOCKET_ERROR = [ - drop port-errored - ] [ - dup zero? [ - drop - t swap set-port-eof? - ] [ - swap n>buffer - ] if - ] if ; - -M: input-port (wait-to-read) ( port -- ) - dup port-handle wince-read ; - -GENERIC: wince-write ( port port-handle -- ) - -M: win32-file wince-write ( port port-handle -- ) - drop dup make-FileArgs dup setup-write WriteFile zero? [ - drop port-errored - ] [ - FileArgs-lpNumberOfBytesRet *uint ! *DWORD - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - flush-output - ] [ - drop - ] if - ] if ; - -: setup-WSASend ( -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine ) - [ WSAArgs-s ] keep - [ - WSAArgs-lpBuffers [ buffer-length ] keep - buffer@ - "WSABUF" - [ windows.winsock:set-WSABUF-buf ] keep - [ windows.winsock:set-WSABUF-len ] keep - ] keep - [ WSAArgs-dwBufferCount ] keep - [ WSAArgs-lpNumberOfBytesRet ] keep - [ WSAArgs-lpFlags ] keep - [ WSAArgs-lpOverlapped ] keep - WSAArgs-lpCompletionRoutine ; - -! M: win32-socket wince-write ( port port-handle -- ) - ! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [ - ! drop port-errored - ! ] [ - ! FileArgs-lpNumberOfBytesRet *uint ! *DWORD - ! over delegate [ buffer-consume ] keep - ! buffer-length 0 > [ - ! flush-output - ! ] [ - ! drop - ! ] if - ! ] if ; - -M: win32-socket wince-write ( port port-handle -- ) - win32-file-handle over - delegate [ buffer@ ] keep - buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = [ - drop port-errored - ] [ - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - flush-output - ] [ - drop - ] if - ] if ; - -M: windows-ce-io flush-output ( port -- ) - dup port-handle wince-write ; - -M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ; - -: do-connect ( addrspec -- socket ) - [ tcp-socket dup ] keep - make-sockaddr/size - f f f f windows.winsock:WSAConnect zero? [ - winsock-error-string throw - ] unless ; - -M: windows-ce-io (client) ( addrspec -- duplex-stream ) - do-connect dup handle>duplex-stream ; - -M: windows-ce-io ( addrspec -- duplex-stream ) - [ - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - f - ] keep ; - -M: windows-ce-io accept ( server -- client ) - dup check-server-port - [ - [ touch-port ] keep - [ port-handle win32-file-handle ] keep - server-port-addr sockaddr-type heap-size - [ "char" ] keep [ - - f 0 - windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = [ - winsock-error-string throw - ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream ; - T{ windows-ce-io } io-backend set-global - -M: windows-ce-io init-io ( -- ) - init-winsock ; - -M: windows-ce-io ( addrspec -- datagram ) - [ - windows.winsock:SOCK_DGRAM server-fd f - ] keep ; - -M: windows-ce-io receive ( datagram -- packet addrspec ) - dup check-datagram-port - [ - port-handle delegate win32-file-handle - "WSABUF" - default-buffer-size over windows.winsock:set-WSABUF-len - default-buffer-size "char" over windows.winsock:set-WSABUF-buf - [ - 1 - 0 [ - 0 - 64 "char" [ - 64 - f - f - windows.winsock:WSARecvFrom zero? [ - winsock-error-string throw - ] unless - ] keep - ] keep *uint - ] keep - ] keep - ! sockaddr count buf datagram - >r windows.winsock:WSABUF-buf swap memory>string swap r> - datagram-port-addr parse-sockaddr ; - -M: windows-ce-io send ( packet addrspec datagram -- ) - 3dup check-datagram-send - delegate port-handle delegate win32-file-handle - rot dup length "WSABUF" - [ windows.winsock:set-WSABUF-len ] keep - [ windows.winsock:set-WSABUF-buf ] keep - - rot make-sockaddr/size - >r >r 1 0 0 r> r> f f - windows.winsock:WSASendTo zero? [ - winsock-error-string throw - ] unless ; - diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor new file mode 100755 index 0000000000..277641a78a --- /dev/null +++ b/extra/io/windows/ce/files/files.factor @@ -0,0 +1,28 @@ +USING: alien alien.c-types combinators io io.backend io.buffers +io.files io.nonblocking io.windows kernel libc math namespaces +prettyprint sequences strings threads threads.private +windows windows.kernel32 io.windows.ce.backend ; +IN: windows.ce.files + +! M: windows-ce-io normalize-pathname ( string -- string ) + ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ; + +M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ; +M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ; + +M: win32-file wince-read + drop dup make-FileArgs dup setup-read ReadFile zero? [ + drop port-errored + ] [ + FileArgs-lpNumberOfBytesRet *uint dup zero? + [ drop t swap set-port-eof? ] [ swap n>buffer ] if + ] if ; + +M: win32-file wince-write ( port port-handle -- ) + drop dup make-FileArgs dup setup-write WriteFile zero? [ + drop port-errored + ] [ + FileArgs-lpNumberOfBytesRet *uint + over buffer-consume + port-flush + ] if ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor new file mode 100755 index 0000000000..8fd1bc5fea --- /dev/null +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -0,0 +1,170 @@ +USING: alien alien.c-types combinators io io.backend io.buffers +io.nonblocking io.sockets io.sockets.impl io.windows kernel libc +math namespaces prettyprint qualified sequences strings threads +threads.private windows windows.kernel32 io.windows.ce.backend +byte-arrays ; +QUALIFIED: windows.winsock +IN: io.windows.ce + +M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ; + +TUPLE: WSAArgs + s + lpBuffers + dwBufferCount + lpNumberOfBytesRet + lpFlags + lpOverlapped + lpCompletionRoutine ; +C: WSAArgs + +: make-WSAArgs ( port -- ) + [ port-handle win32-file-handle ] keep + 1 "DWORD" f f f ; + +: setup-WSARecv ( -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine ) + [ WSAArgs-s ] keep + [ + WSAArgs-lpBuffers [ buffer-capacity ] keep + buffer-end + "WSABUF" + [ windows.winsock:set-WSABUF-buf ] keep + [ windows.winsock:set-WSABUF-len ] keep + ] keep + [ WSAArgs-dwBufferCount ] keep + [ WSAArgs-lpNumberOfBytesRet ] keep + [ WSAArgs-lpFlags ] keep + [ WSAArgs-lpOverlapped ] keep + WSAArgs-lpCompletionRoutine ; + +! M: win32-socket wince-read ( port port-handle -- ) + ! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [ + ! drop port-errored + ! ] [ + ! WSAArgs-lpNumberOfBytesRet *uint dup zero? [ + ! drop + ! t swap set-port-eof? + ! ] [ + ! swap n>buffer + ! ] if + ! ] if ; + +M: win32-socket wince-read ( port port-handle -- ) + win32-file-handle over buffer-end pick buffer-capacity 0 + windows.winsock:recv + dup windows.winsock:SOCKET_ERROR = [ + drop port-errored + ] [ + dup zero? [ + drop + t swap set-port-eof? + ] [ + swap n>buffer + ] if + ] if ; + +: setup-WSASend ( -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine ) + [ WSAArgs-s ] keep + [ + WSAArgs-lpBuffers [ buffer-length ] keep + buffer@ + "WSABUF" + [ windows.winsock:set-WSABUF-buf ] keep + [ windows.winsock:set-WSABUF-len ] keep + ] keep + [ WSAArgs-dwBufferCount ] keep + [ WSAArgs-lpNumberOfBytesRet ] keep + [ WSAArgs-lpFlags ] keep + [ WSAArgs-lpOverlapped ] keep + WSAArgs-lpCompletionRoutine ; + +! M: win32-socket wince-write ( port port-handle -- ) + ! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [ + ! drop port-errored + ! ] [ + ! FileArgs-lpNumberOfBytesRet *uint ! *DWORD + ! over delegate [ buffer-consume ] keep + ! buffer-length 0 > [ + ! flush-output + ! ] [ + ! drop + ! ] if + ! ] if ; + +M: win32-socket wince-write ( port port-handle -- ) + win32-file-handle over buffer@ pick buffer-length 0 + windows.winsock:send + dup windows.winsock:SOCKET_ERROR = + [ drop port-errored ] [ over buffer-consume port-flush ] if ; + +: do-connect ( addrspec -- socket ) + [ tcp-socket dup ] keep + make-sockaddr/size + f f f f windows.winsock:WSAConnect zero? + [ windows.winsock:winsock-error ] unless ; + +M: windows-ce-io (client) ( addrspec -- duplex-stream ) + do-connect dup handle>duplex-stream ; + +M: windows-ce-io ( addrspec -- duplex-stream ) + [ + windows.winsock:SOCK_STREAM server-fd + dup listen-on-socket + f + ] keep ; + +M: windows-ce-io accept ( server -- client ) + dup check-server-port + [ + dup touch-port + dup port-handle win32-file-handle + swap server-port-addr sockaddr-type heap-size + dup [ + swap f 0 + windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = + [ windows.winsock:winsock-error ] when + ] keep + ] keep server-port-addr parse-sockaddr swap + dup handle>duplex-stream ; + +M: windows-ce-io ( addrspec -- datagram ) + [ + windows.winsock:SOCK_DGRAM server-fd f + ] keep ; + +M: windows-ce-io receive ( datagram -- packet addrspec ) + dup check-datagram-port + [ + port-handle win32-file-handle + "WSABUF" + default-buffer-size get over windows.winsock:set-WSABUF-len + default-buffer-size get over windows.winsock:set-WSABUF-buf + [ + 1 + 0 [ + 0 + 64 "char" [ + 64 + f + f + windows.winsock:WSARecvFrom zero? + [ windows.winsock:winsock-error ] unless + ] keep + ] keep *uint + ] keep + ] keep + ! sockaddr count buf datagram + >r windows.winsock:WSABUF-buf swap memory>string swap r> + datagram-port-addr parse-sockaddr ; + +M: windows-ce-io send ( packet addrspec datagram -- ) + 3dup check-datagram-send + port-handle win32-file-handle + rot dup length "WSABUF" + [ windows.winsock:set-WSABUF-len ] keep + [ windows.winsock:set-WSABUF-buf ] keep + + rot make-sockaddr/size + >r >r 1 0 0 r> r> f f + windows.winsock:WSASendTo zero? + [ windows.winsock:winsock-error ] unless ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a67aa96ce8..037253db11 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -83,8 +83,8 @@ C: pipe PIPE_ACCESS_DUPLEX FILE_FLAG_OVERLAPPED bitor PIPE_TYPE_BYTE PIPE_READMODE_BYTE PIPE_NOWAIT bitor bitor PIPE_UNLIMITED_INSTANCES - default-buffer-size - default-buffer-size + default-buffer-size get + default-buffer-size get 0 security-attributes-inherit CreateNamedPipe dup invalid-handle? ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 0cbdabfa1e..16e01b6103 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,13 +1,10 @@ -USING: alien alien.c-types arrays assocs combinators continuations -destructors io io.backend io.nonblocking io.windows libc -kernel math namespaces sequences threads tuples.lib windows -windows.errors windows.kernel32 prettyprint strings splitting -io.files windows.winsock ; +USING: alien alien.c-types arrays assocs combinators +continuations destructors io io.backend io.nonblocking +io.windows libc kernel math namespaces sequences threads +tuples.lib windows windows.errors windows.kernel32 strings +splitting io.files windows.winsock ; IN: io.windows.nt.backend -: .. global [ . flush ] bind ; -: .S global [ .s flush ] bind ; - : unicode-prefix ( -- seq ) "\\\\?\\" ; inline @@ -51,6 +48,12 @@ C: io-callback >r (make-overlapped) r> port-handle win32-file-ptr [ over set-OVERLAPPED-offset ] when* ; +: port-overlapped ( port -- overlapped ) + port-handle win32-file-overlapped ; + +: set-port-overlapped ( overlapped port -- ) + port-handle set-win32-file-overlapped ; + : completion-port ( handle existing -- handle ) f 1 CreateIoCompletionPort dup win32-error=0/f ; @@ -75,7 +78,7 @@ C: GetOverlappedResult-args : (save-callback) ( io-callback -- ) dup io-callback-port port-handle win32-file-overlapped - \ io-hash get-global set-at ; + io-hash get-global set-at ; : save-callback ( port -- ) [ @@ -95,7 +98,7 @@ C: GetQueuedCompletionStatusParams : lookup-callback ( GetQueuedCompletion-args -- callback ) GetQueuedCompletionStatusParams-lpOverlapped* *void* - \ io-hash get-global delete-at* drop ; + io-hash get-global delete-at* drop ; : wait-for-io ( timeout -- continuation/f ) wait-for-overlapped @@ -125,19 +128,17 @@ C: GetQueuedCompletionStatusParams drop ] if ; -: cancel-timedout ( -- ) +: cancel-timeout ( -- ) io-hash get-global values [ maybe-expire ] each ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timedout - [ wait-for-io ] [ global [ "error: " write . flush ] bind drop f ] recover - [ schedule-thread ] when* ; + cancel-timeout wait-for-io [ schedule-thread ] when* ; M: windows-nt-io init-io ( -- ) #! Should only be called on startup. Calling this at any #! other time can have unintended consequences. global [ master-completion-port \ master-completion-port set - H{ } clone \ io-hash set + H{ } clone io-hash set init-winsock ] bind ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor old mode 100644 new mode 100755 index 791b03ab5e..530bc14c3a --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -17,26 +17,24 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) 2drop ] if* ; -DEFER: (flush-output) : finish-flush ( port -- ) dup pending-error dup get-overlapped-result - [ over update-file-ptr ] keep - over delegate [ buffer-consume ] keep - buffer-length 0 > [ - (flush-output) - ] [ - drop - ] if ; + dup pick update-file-ptr + swap buffer-consume ; + +: save-overlapped-and-callback ( fileargs port -- ) + swap FileArgs-lpOverlapped over set-port-overlapped + save-callback ; : (flush-output) ( port -- ) dup touch-port dup make-FileArgs - [ setup-write WriteFile ] keep - >r dupd overlapped-error? r> swap [ - FileArgs-lpOverlapped over set-port-overlapped - dup save-callback - finish-flush + tuck setup-write WriteFile + dupd overlapped-error? [ + [ save-overlapped-and-callback ] keep + [ finish-flush ] keep + dup buffer-empty? [ drop ] [ (flush-output) ] if ] [ 2drop ] if ; @@ -49,17 +47,16 @@ M: windows-nt-io flush-output ( port -- ) dup get-overlapped-result dup zero? [ drop t swap set-port-eof? ] [ - [ over n>buffer ] keep + dup pick n>buffer swap update-file-ptr ] if ; : ((wait-to-read)) ( port -- ) dup touch-port dup make-FileArgs - [ setup-read ReadFile ] keep - >r dupd overlapped-error? r> swap [ - FileArgs-lpOverlapped over set-port-overlapped - dup save-callback + tuck setup-read ReadFile + dupd overlapped-error? [ + [ save-overlapped-and-callback ] keep finish-read ] [ 2drop diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 1b6288eb1d..74538ac06a 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -178,7 +178,7 @@ TUPLE: WSARecvFrom-args port ] keep "WSABUF" malloc-object dup free-always 2dup swap set-WSARecvFrom-args-lpBuffers* - default-buffer-size [ malloc dup free-always ] keep + default-buffer-size get [ malloc dup free-always ] keep pick set-WSABUF-len swap set-WSABUF-buf 1 over set-WSARecvFrom-args-dwBufferCount* @@ -256,6 +256,8 @@ TUPLE: WSASendTo-args port \ WSASendTo-args >tuple*< WSASendTo socket-error* ; +USE: io.sockets + M: windows-nt-io send ( packet addrspec datagram -- ) [ 3dup check-datagram-send diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor old mode 100644 new mode 100755 index 8d6d7cb6f2..894874a60b --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -31,12 +31,6 @@ TUPLE: win32-file handle ptr overlapped ; { set-win32-file-handle set-win32-file-ptr } \ win32-file construct ; -: set-port-overlapped ( overlapped port -- ) - port-handle set-win32-file-overlapped ; - -: port-overlapped ( port -- overlapped ) - port-handle win32-file-overlapped ; - HOOK: CreateFile-flags io-backend ( -- DWORD ) HOOK: flush-output io-backend ( port -- ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) @@ -48,7 +42,14 @@ M: windows-io normalize-directory ( string -- string ) : share-mode ( -- fixnum ) FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline -M: win32-file init-handle ( handle -- ) drop ; +M: win32-file init-handle ( handle -- ) + drop ; + +M: win32-file close-handle ( handle -- ) + win32-file-handle CloseHandle drop ; + +M: port port-flush + dup buffer-empty? [ dup flush-output ] unless drop ; ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode -- handle ) @@ -101,27 +102,6 @@ C: FileArgs [ FileArgs-lpNumberOfBytesRet ] keep FileArgs-lpOverlapped ; -M: output-port stream-flush ( port -- ) - dup buffer-empty? [ - dup flush-output - ] unless pending-error ; - -M: port stream-close ( port -- ) - dup port-type closed = [ - drop - ] [ - ! For duplex-streams, we call CloseHandle twice on the same handle - [ dup port-type output = [ stream-flush ] [ drop ] if ] keep - [ closed swap set-port-type ] keep - [ port-handle win32-file-handle CloseHandle drop ] keep - USE: namespaces - [ delegate [ buffer-free ] [ - global [ "delegate was empty!!" print flush ] bind - USE: windows.winsock.private - ] if* ] keep - f swap set-delegate - ] if ; - M: windows-io ( path -- stream ) open-read ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index bc9dd0ffeb..88f94a7fd6 100644 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -76,4 +76,5 @@ TUPLE: expected-error ; : test-all ( -- ) "" test ; -: test-changes ( -- ) "" (refresh) run-vocab-tests ; +: test-changes ( -- ) + "" to-refresh dupd do-refresh run-vocab-tests ; diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor old mode 100644 new mode 100755 index 9a031baa1e..f87ebab0d8 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -166,9 +166,8 @@ FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ; FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ; FUNCTION: int closesocket ( SOCKET s ) ; FUNCTION: int shutdown ( SOCKET s, int how ) ; -! FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; -! FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; - +FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; +FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED @@ -405,6 +404,9 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi : winsock-error-string ( -- string/f ) WSAGetLastError (winsock-error-string) ; +: winsock-error ( -- ) + winsock-error-string [ throw ] when* ; + : winsock-error=0/f ( n/f -- ) { 0 f } member? [ winsock-error-string throw @@ -428,7 +430,7 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi ] when ; : socket-error ( n -- ) - SOCKET_ERROR = [ winsock-error-string throw ] when ; + SOCKET_ERROR = [ winsock-error ] when ; : init-winsock ( -- ) HEX: 0202 WSAStartup winsock-error!=0/f ; diff --git a/vm/factor.c b/vm/factor.c index 4dee712c0b..690f5d490c 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -13,7 +13,7 @@ void default_parameters(F_PARAMETERS *p) p->gen_count = 2; p->code_size = 4; p->young_size = 1; - p->aging_size = 4; + p->aging_size = 6; #else p->ds_size = 32 * CELLS; p->rs_size = 32 * CELLS; diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.c index 217fb58fa7..39a3da0b3f 100644 --- a/vm/os-linux-arm.c +++ b/vm/os-linux-arm.c @@ -8,6 +8,9 @@ void flush_icache(CELL start, CELL len) identically to the below assembly. */ /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ + /* Assembly swiped from + http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html + */ __asm__ __volatile__ ( "mov r0, %1\n" "sub r1, %2, #1\n"