GENERIC# n, 1 ( value n -- )
M: integer n, >le % ;
-M: byte n, >r value>> r> n, ;
+M: byte n, [ value>> ] dip n, ;
: 1, ( n -- ) 1 n, ; inline
: 4, ( n -- ) 4 n, ; inline
: 2, ( n -- ) 2 n, ; inline
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
#! the opcode.
- >r dupd prefix-1 reg-code r> + , ;
+ [ dupd prefix-1 reg-code ] dip + , ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: 1-operand ( op reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
- first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
+ first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
] if ;
: (2-operand) ( dst src op -- )
- >r 2dup t rex-prefix r> opcode,
+ [ 2dup t rex-prefix ] dip opcode,
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
PRIVATE>
: [] ( reg/displacement -- indirect )
- dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
+ dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
- [ dup zero? [ drop f ] when >r f f r> ]
+ [ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
- >r >r "cpu.x86.assembler" create dup define-symbol r> r>
- >r dupd "register" set-word-prop r>
+ [ "cpu.x86.assembler" create dup define-symbol ] 2dip
+ [ dupd "register" set-word-prop ] dip
"register-size" set-word-prop ;
: define-registers ( names size -- )
: buffer-set ( string buffer -- )
over >byte-array over ptr>> byte-array>memory
- >r length r> buffer-reset ;
+ [ length ] dip buffer-reset ;
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor
+ [ 2 shift ] dip BIN: 11 bitand bitor
over stream-read1 swap append-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;
SYMBOL: +rename-file+
: with-monitor ( path recursive? quot -- )
- >r <monitor> r> with-disposal ; inline
+ [ <monitor> ] dip with-disposal ; inline
{
{ [ os macosx? ] [ "io.unix.macosx.monitors" require ] }
USING: accessors sequences assocs arrays continuations
destructors combinators kernel threads concurrency.messaging
concurrency.mailboxes concurrency.promises io.files io.monitors
-debugger ;
+debugger fry ;
IN: io.monitors.recursive
! Simulate recursive monitors on platforms that don't have them
qualify-path dup link-info directory? [
[ add-child-monitors ]
[
- [
- [ f my-mailbox (monitor) ] keep
+ '[
+ _ [ f my-mailbox (monitor) ] keep
monitor tget children>> set-at
- ] curry ignore-errors
+ ] ignore-errors
] bi
] [ drop ] if ;
monitor tget children>> [ nip dispose ] assoc-each ;
: pump-step ( msg -- )
- first3 path>> swap >r prepend-path r> monitor tget 3array
+ first3 path>> swap [ prepend-path ] dip monitor tget 3array
monitor tget queue>>
mailbox-put ;
: pump-loop ( -- )
receive dup synchronous? [
- >r stop-pump t r> reply-synchronous
+ [ stop-pump t ] dip reply-synchronous
] [
- [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
+ [ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
pump-loop
] if ;
pump-loop ;
: start-pump-thread ( monitor -- )
- dup [ pump-thread ] curry
+ dup '[ _ pump-thread ]
"Recursive monitor pump" spawn
>>thread drop ;
ready>> ?promise ?linked drop ;
: <recursive-monitor> ( path mailbox -- monitor )
- >r (normalize-path) r>
+ [ (normalize-path) ] dip
recursive-monitor new-monitor
H{ } clone >>children
<promise> >>ready
[ nip call ] [ drop return-connection ] 3bi ; inline
: with-pooled-connection ( pool quot -- )
- >r [ acquire-connection ] keep r>
+ [ [ acquire-connection ] keep ] dip
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
M: return-connection dispose
] with-destructors ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
- tuck re-encode >r re-decode r> <duplex-stream> ;
+ tuck [ re-decode ] [ re-encode ] 2bi* <duplex-stream> ;
: with-stream* ( stream quot -- )
[ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel calendar alarms io io.encodings accessors\r
-namespaces ;\r
+namespaces fry ;\r
IN: io.timeouts\r
\r
GENERIC: timeout ( obj -- dt/f )\r
GENERIC: cancel-operation ( obj -- )\r
\r
: queue-timeout ( obj timeout -- alarm )\r
- >r [ cancel-operation ] curry r> later ;\r
+ [ '[ _ cancel-operation ] ] dip later ;\r
\r
: with-timeout* ( obj timeout quot -- )\r
- 3dup drop queue-timeout >r nip call r> cancel-alarm ;\r
+ 3dup drop queue-timeout [ nip call ] dip cancel-alarm ;\r
inline\r
\r
: with-timeout ( obj quot -- )\r
- over timeout [ >r dup timeout r> with-timeout* ] [ call ] if ;\r
+ over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ;\r
inline\r
\r
: timeouts ( dt -- )\r
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
-locals unix.time ;
+locals unix.time fry ;
QUALIFIED: io
IN: io.unix.backend
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
- [
- >r
- swap handle-fd
- mx get-global
- r> {
+ '[
+ swap handle-fd mx get-global _ {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
- ] curry "I/O" suspend nip [ io-timeout ] when
+ ] "I/O" suspend nip [ io-timeout ] when
] if ;
: wait-for-port ( port event -- )
- [ >r handle>> r> wait-for-fd ] curry with-timeout ;
+ '[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff
: file-mode OCT: 0666 ;
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
: add-watch ( path mask mailbox -- monitor )
- >r
- >r (normalize-path) r>
- [ (add-watch) ] [ drop ] 2bi r>
+ [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
: check-inotify ( -- )
: next-event ( i buffer -- i buffer )
2dup inotify-event@
inotify-event-len "inotify-event" heap-size +
- swap >r + r> ;
+ swap [ + ] dip ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
2dup inotify-event@ dup inotify-event-wd wd>monitor
- >r parse-file-notify r> queue-change
+ [ parse-file-notify ] dip queue-change
next-event parse-file-notifications
] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.monitors
core-foundation.fsevents continuations kernel sequences
-namespaces arrays system locals accessors destructors ;
+namespaces arrays system locals accessors destructors fry ;
IN: io.unix.macosx.monitors
TUPLE: macosx-monitor < monitor handle ;
: enqueue-notifications ( triples monitor -- )
- [
- >r first { +modify-file+ } r> queue-change
- ] curry each ;
+ '[ first { +modify-file+ } _ queue-change ] each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
[let | path [ path normalize-path ] |
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix math namespaces
-accessors math.order locals unix.time ;
+accessors math.order locals unix.time fry ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
[ check-fd ] 3curry each ; inline
: init-fdset ( fds fdset -- )
- [ >r t swap munge r> set-nth ] curry each ;
+ '[ t swap munge _ set-nth ] each ;
: read-fdset/tasks ( mx -- seq fdset )
[ reads>> keys ] [ read-fdset>> ] bi ;
0 socket dup io-error <fd> init-fd |dispose ;
: set-socket-option ( fd level opt -- )
- >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
+ [ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
- >r handle-fd r> empty-sockaddr/size <int>
+ [ handle-fd ] dip 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>
+ [ handle-fd ] dip empty-sockaddr/size <int>
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR set-socket-option ;
: server-socket-fd ( addrspec type -- fd )
- >r dup protocol-family r> socket-fd
+ [ dup protocol-family ] dip socket-fd
dup init-server-socket
dup handle-fd rot make-sockaddr/size bind io-error ;
M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
- { [ over 0 >= ] [ >r 2nip <fd> init-fd r> ] }
+ { [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
"Receive 1" print
- "d" get receive >r reverse r>
+ "d" get receive [ reverse ] dip
"Send 1" print
dup .
"Receive 2" print
- "d" get receive >r " world" append r>
+ "d" get receive [ " world" append ] dip
"Send 1" print
dup .
[ "olleh" t ] [
"d" get receive
datagram-server <local> =
- >r >string r>
+ [ >string ] dip
] unit-test
[ ] [
[ "hello world" t ] [
"d" get receive
datagram-server <local> =
- >r >string r>
+ [ >string ] dip
] unit-test
[ ] [ "d" get dispose ] unit-test
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r share-mode default-security-attributes r> r>
+ [ share-mode default-security-attributes ] 2dip
CreateFile-flags f CreateFile opened-file
] with-destructors ;
GetLastError ERROR_ALREADY_EXISTS = not ;
: set-file-pointer ( handle length method -- )
- >r dupd d>w/w <uint> r> SetFilePointer
+ [ dupd d>w/w <uint> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [
CloseHandle "SetFilePointer failed" throw
] when drop ;
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
#! timestamp order: creation access write
[
- >r >r >r
+ [
normalize-path open-existing &dispose handle>>
- r> r> r> (set-file-times)
+ ] 3dip (set-file-times)
] with-destructors ;
: set-file-create-time ( path timestamp -- )
f f set-file-times ;
: set-file-access-time ( path timestamp -- )
- >r f r> f set-file-times ;
+ [ f ] dip f set-file-times ;
: set-file-write-time ( path timestamp -- )
- >r f f r> set-file-times ;
+ [ f f ] dip set-file-times ;
M: winnt touch-file ( path -- )
[
normalize-path
- maybe-create-file >r &dispose r>
+ maybe-create-file [ &dispose ] dip
[ drop ] [ handle>> f now dup (set-file-times) ] if
] with-destructors ;
"OVERLAPPED" malloc-object &free ;
: make-overlapped ( port -- overlapped-ext )
- >r (make-overlapped)
- r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
+ [ (make-overlapped) ] dip
+ handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
: handle-overlapped ( us -- ? )
wait-for-overlapped [
dup [
- >r drop GetLastError 1array r> resume-callback t
- ] [
- 2drop f
- ] if
- ] [
- resume-callback t
- ] if ;
+ [ drop GetLastError 1array ] dip resume-callback t
+ ] [ 2drop f ] if
+ ] [ resume-callback t ] if ;
M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
- [ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
+ [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
- >r (open-append) r> >>ptr ;
+ [ (open-append) ] dip >>ptr ;
M: winnt home "USERPROFILE" os-env ;
CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
: redirect-append ( path access-mode create-mode -- handle )
- >r >r path>> r> r>
+ [ path>> ] 2dip
drop OPEN_ALWAYS
redirect-file
dup 0 FILE_END set-file-pointer ;
2drop handle>> duplicate-handle ;
: redirect-stream ( stream access-mode create-mode -- handle )
- >r >r underlying-handle handle>> r> r> redirect-handle ;
+ [ underlying-handle handle>> ] 2dip redirect-handle ;
: redirect ( obj access-mode create-mode -- handle )
{
\r
: with-process-token ( quot -- )\r
#! quot: ( token-handle -- token-handle )\r
- >r open-process-token r>\r
+ [ open-process-token ] dip\r
[ keep ] curry\r
[ CloseHandle drop ] [ ] cleanup ; inline\r
\r
: lookup-privilege ( string -- luid )\r
- >r f r> "LUID" <c-object>\r
+ [ f ] dip "LUID" <c-object>\r
[ LookupPrivilegeValue win32-error=0/f ] keep ;\r
\r
: make-token-privileges ( name ? -- obj )\r
set-LUID_AND_ATTRIBUTES-Attributes\r
] when\r
\r
- >r lookup-privilege r>\r
+ [ lookup-privilege ] dip\r
[\r
TOKEN_PRIVILEGES-Privileges\r
- >r 0 r> LUID_AND_ATTRIBUTES-nth\r
+ [ 0 ] dip LUID_AND_ATTRIBUTES-nth\r
set-LUID_AND_ATTRIBUTES-Luid\r
] keep ;\r
\r
: make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object &free
- [ >r malloc-byte-array &free r> set-WSABUF-buf ]
- [ >r length r> set-WSABUF-len ]
+ [ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
+ [ [ length ] dip set-WSABUF-len ]
[ nip ]
2tri ; inline
swap >>port
dup port>> handle>> handle>> >>s
swap make-sockaddr/size
- >r malloc-byte-array &free
- r> [ >>lpTo ] [ >>iToLen ] bi*
+ [ malloc-byte-array &free ] dip
+ [ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags
<win32-socket> |dispose dup add-completion ;\r
\r
: open-socket ( addrspec type -- win32-socket )\r
- >r protocol-family r>\r
+ [ protocol-family ] dip\r
0 f 0 WSASocket-flags WSASocket\r
dup socket-error\r
opened-socket ;\r
\r
M: object (get-local-address) ( socket addrspec -- sockaddr )\r
- >r handle>> r> empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
[ getsockname socket-error ] 2keep drop ;\r
\r
M: object (get-remote-address) ( socket addrspec -- sockaddr )\r
- >r handle>> r> empty-sockaddr/size <int>\r
+ [ handle>> ] dip empty-sockaddr/size <int>\r
[ getpeername socket-error ] 2keep drop ;\r
\r
: bind-socket ( win32-socket sockaddr len -- )\r
- >r >r handle>> r> r> bind socket-error ;\r
+ [ handle>> ] 2dip bind socket-error ;\r
\r
M: object ((client)) ( addrspec -- handle )\r
[ SOCK_STREAM open-socket ] keep\r
IN: io.windows
: set-inherit ( handle ? -- )
- >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
+ [ HANDLE_FLAG_INHERIT ] dip
+ >BOOLEAN SetHandleInformation win32-error=0/f ;
TUPLE: win32-handle handle disposed ;
\r
TUPLE: range < compose ;\r
\r
-: <range> ( value min max page -- range )\r
+: <range> ( value page min max -- range )\r
4array [ <model> ] map range new-compose ;\r
\r
: range-model ( range -- model ) dependencies>> first ;\r
<PRIVATE
-: root? ( string -- ? ) vocab-roots get member? ;
+: root? ( string -- ? ) vocab-roots get member? ;
-: length-changes? ( seq quot -- ? )
- dupd call [ length ] bi@ = not ; inline
+: contains-dot? ( string -- ? ) ".." swap subseq? ;
-: check-vocab-name ( string -- string )
- dup [ [ CHAR: . = ] trim ] length-changes?
- [ vocab-name-contains-dot ] when
-
- ".." over subseq? [ vocab-name-contains-dot ] when
+: contains-separator? ( string -- ? ) [ path-separator? ] contains? ;
- dup [ path-separator? ] contains?
- [ vocab-name-contains-separator ] when ;
+: check-vocab-name ( string -- string )
+ dup contains-dot? [ vocab-name-contains-dot ] when
+ dup contains-separator? [ vocab-name-contains-separator ] when ;
: check-root ( string -- string )
- check-vocab-name
- dup "resource:" head? [ "resource:" prepend ] unless
dup root? [ not-a-vocab-root ] unless ;
: directory-exists ( path -- )
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
{ freebsd [ "unix.statfs.freebsd" require ] }
- ! { netbsd [ "unix.statfs.netbsd" require ] }
- ! { openbsd [ "unix.statfs.openbsd" require ] }
+ { netbsd [ ] }
+ { openbsd [ ] }
} case
projects / factor.git / commitdiff