steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://factorcode.org/git/factor

release
Doug Coleman 2007-11-08 01:03:00 -06:00
parent 8ebc4347d8 6ccf4ddb24
commit e24d063b86
37 changed files with 354 additions and 335 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/alien-tests.factor
View File

@ -64,3 +64,7 @@ cell 8 = [
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] unit-test-fails
[ 1 1 <displaced-alien> ] unit-test-fails
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test

2
core/alien/alien.factor
View File

@ -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 ;

4
core/alien/c-types/c-types-tests.factor
View File

@ -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 } <displaced-alien> <void*>
] unit-test-fails

12
core/alien/syntax/syntax.factor
View File

@ -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
<PRIVATE
@ -53,10 +53,10 @@ PRIVATE>
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 ;

26
core/vocabs/loader/loader.factor
View File

@ -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 ;

0
core/bootstrap/help/authors.txt → extra/bootstrap/help/authors.txt
View File

0
core/bootstrap/help/help.factor → extra/bootstrap/help/help.factor
View File

0
core/bootstrap/help/summary.txt → extra/bootstrap/help/summary.txt
View File

0
core/bootstrap/io/authors.txt → extra/bootstrap/io/authors.txt
View File

0
core/bootstrap/io/io.factor → extra/bootstrap/io/io.factor
View File

0
core/bootstrap/io/summary.txt → extra/bootstrap/io/summary.txt
View File

0
core/bootstrap/math/math.factor → extra/bootstrap/math/math.factor
View File

0
core/bootstrap/math/summary.txt → extra/bootstrap/math/summary.txt
View File

0
core/bootstrap/tools/authors.txt → extra/bootstrap/tools/authors.txt
View File

0
core/bootstrap/tools/summary.txt → extra/bootstrap/tools/summary.txt
View File

0
core/bootstrap/tools/tools.factor → extra/bootstrap/tools/tools.factor
View File

0
core/bootstrap/ui/authors.txt → extra/bootstrap/ui/authors.txt
View File

0
core/bootstrap/ui/summary.txt → extra/bootstrap/ui/summary.txt
View File

0
core/bootstrap/ui/tools/authors.txt → extra/bootstrap/ui/tools/authors.txt
View File

0
core/bootstrap/ui/tools/summary.txt → extra/bootstrap/ui/tools/summary.txt
View File

0
core/bootstrap/ui/tools/tools.factor → extra/bootstrap/ui/tools/tools.factor
View File

0
core/bootstrap/ui/ui.factor → extra/bootstrap/ui/ui.factor
View File

24
extra/io/nonblocking/nonblocking.factor Normal file → Executable file
View File

@ -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 -- )
: <port> ( handle buffer -- port )
over init-handle
@ -29,7 +31,7 @@ GENERIC: init-handle ( handle -- )
} port construct ;
: <buffered-port> ( handle -- port )
default-buffer-size <buffer> <port> ;
default-buffer-size get <buffer> <port> ;
: <reader> ( handle -- stream )
<buffered-port> input over set-port-type <line-reader> ;
@ -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 ;
: <server-port> ( port addr -- server )

17
extra/io/unix/backend/backend.factor Normal file → Executable file
View File

@ -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 <write-task> 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 ( -- )

42
extra/io/windows/ce/backend/backend.factor Executable file
View File

@ -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 <win32-file> <reader>
r> f <win32-file> <writer>
] with-variable <duplex-stream> stdio set ;

234
extra/io/windows/ce/ce.factor Normal file → Executable file
View File

@ -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> WSAArgs
: make-WSAArgs ( port -- <WSARecv> )
[ port-handle win32-file-handle ] keep
delegate 1 "DWORD" <c-object> f f f <WSAArgs> ;
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-capacity ] keep
buffer-end
"WSABUF" <c-object>
[ 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 ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-length ] keep
buffer@
"WSABUF" <c-object>
[ 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 <win32-socket> dup handle>duplex-stream ;
M: windows-ce-io <server> ( addrspec -- duplex-stream )
[
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> f <port>
] keep <server-port> ;
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" <c-array> ] keep [
<int>
f 0
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = [
winsock-error-string throw
] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream> ;
T{ windows-ce-io } io-backend set-global
M: windows-ce-io init-io ( -- )
init-winsock ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
] keep <datagram-port> ;
M: windows-ce-io receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle delegate win32-file-handle
"WSABUF" <c-object>
default-buffer-size over windows.winsock:set-WSABUF-len
default-buffer-size "char" <c-array> over windows.winsock:set-WSABUF-buf
[
1
0 <uint> [
0 <uint>
64 "char" <c-array> [
64 <int>
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" <c-object>
[ windows.winsock:set-WSABUF-len ] keep
[ windows.winsock:set-WSABUF-buf ] keep
rot make-sockaddr/size
>r >r 1 0 <uint> 0 r> r> f f
windows.winsock:WSASendTo zero? [
winsock-error-string throw
] unless ;

28
extra/io/windows/ce/files/files.factor Executable file
View File

@ -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 ;

170
extra/io/windows/ce/sockets/sockets.factor Executable file
View File

@ -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> WSAArgs
: make-WSAArgs ( port -- <WSARecv> )
[ port-handle win32-file-handle ] keep
1 "DWORD" <c-object> f f f <WSAArgs> ;
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-capacity ] keep
buffer-end
"WSABUF" <c-object>
[ 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 ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-length ] keep
buffer@
"WSABUF" <c-object>
[ 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 <win32-socket> dup handle>duplex-stream ;
M: windows-ce-io <server> ( addrspec -- duplex-stream )
[
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> f <port>
] keep <server-port> ;
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 <byte-array> [
swap <int> f 0
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> dup handle>duplex-stream <client-stream> ;
M: windows-ce-io <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
] keep <datagram-port> ;
M: windows-ce-io receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
"WSABUF" <c-object>
default-buffer-size get over windows.winsock:set-WSABUF-len
default-buffer-size get <byte-array> over windows.winsock:set-WSABUF-buf
[
1
0 <uint> [
0 <uint>
64 "char" <c-array> [
64 <int>
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" <c-object>
[ windows.winsock:set-WSABUF-len ] keep
[ windows.winsock:set-WSABUF-buf ] keep
rot make-sockaddr/size
>r >r 1 0 <uint> 0 r> r> f f
windows.winsock:WSASendTo zero?
[ windows.winsock:winsock-error ] unless ;

4
extra/io/windows/launcher/launcher.factor
View File

@ -83,8 +83,8 @@ C: <pipe> 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? ;

31
extra/io/windows/nt/backend/backend.factor
View File

@ -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> 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> 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> 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> 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 ;

33
extra/io/windows/nt/files/files.factor Normal file → Executable file
View File

@ -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

4
extra/io/windows/nt/sockets/sockets.factor
View File

@ -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

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

@ -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
[ 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 <file-reader> ( path -- stream )
open-read <win32-file> <reader> ;

3
extra/tools/test/test.factor
View File

@ -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 ;

10
extra/windows/winsock/winsock.factor Normal file → Executable file
View File

@ -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 <wsadata> WSAStartup winsock-error!=0/f ;

2
vm/factor.c
View File

@ -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;

3
vm/os-linux-arm.c
View File

@ -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"