Merge branch 'master' of git://factorcode.org/git/factor
commit
05d6cf873f
|
@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
|
||||||
|
|
||||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||||
|
|
||||||
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
|
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
|
||||||
|
|
||||||
[ 123 ] [ foo ] unit-test
|
[ 123 ] [ foo ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -77,6 +77,11 @@ HELP: C-ENUM:
|
||||||
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
|
{ $code "C-ENUM: red green blue ;" ": red 0 ; : green 1 ; : blue 2 ;" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: &:
|
||||||
|
{ $syntax "&: symbol" }
|
||||||
|
{ $values { "symbol" "A C library symbol name" } }
|
||||||
|
{ $description "Pushes the address of a symbol named " { $snippet "symbol" } " from the current library, set with " { $link POSTPONE: LIBRARY: } "." } ;
|
||||||
|
|
||||||
HELP: typedef
|
HELP: typedef
|
||||||
{ $values { "old" "a string" } { "new" "a string" } }
|
{ $values { "old" "a string" } { "new" "a string" } }
|
||||||
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: accessors arrays alien alien.c-types alien.structs
|
USING: accessors arrays alien alien.c-types alien.structs
|
||||||
alien.arrays alien.strings kernel math namespaces parser
|
alien.arrays alien.strings kernel math namespaces parser
|
||||||
sequences words quotations math.parser splitting grouping
|
sequences words quotations math.parser splitting grouping
|
||||||
effects assocs combinators lexer strings.parser alien.parser ;
|
effects assocs combinators lexer strings.parser alien.parser
|
||||||
|
fry ;
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
|
|
||||||
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
|
||||||
|
@ -33,3 +34,7 @@ IN: alien.syntax
|
||||||
dup length
|
dup length
|
||||||
[ [ create-in ] dip 1quotation define ] 2each ;
|
[ [ create-in ] dip 1quotation define ] 2each ;
|
||||||
parsing
|
parsing
|
||||||
|
|
||||||
|
: &:
|
||||||
|
scan "c-library" get
|
||||||
|
'[ _ _ load-library dlsym ] over push-all ; parsing
|
||||||
|
|
|
@ -83,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
|
||||||
|
|
||||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||||
|
|
||||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||||
|
|
||||||
: indirect-test-1' ( ptr -- )
|
: indirect-test-1' ( ptr -- )
|
||||||
"int" { } "cdecl" alien-indirect drop ;
|
"int" { } "cdecl" alien-indirect drop ;
|
||||||
|
|
||||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||||
|
|
||||||
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
|
[ ] [ &: ffi_test_1 indirect-test-1' ] unit-test
|
||||||
|
|
||||||
[ -1 indirect-test-1 ] must-fail
|
[ -1 indirect-test-1 ] must-fail
|
||||||
|
|
||||||
|
@ -100,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
|
||||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||||
|
|
||||||
[ 5 ]
|
[ 5 ]
|
||||||
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
|
[ 2 3 &: ffi_test_2 indirect-test-2 ]
|
||||||
unit-test
|
unit-test
|
||||||
|
|
||||||
: indirect-test-3 ( a b c d ptr -- result )
|
: indirect-test-3 ( a b c d ptr -- result )
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov
|
! Copyright (C) 2006, 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||||
math sequences io.encodings.utf8 destructors accessors
|
math math.bitwise sequences io.encodings.utf8 destructors
|
||||||
combinators byte-arrays ;
|
accessors combinators byte-arrays ;
|
||||||
IN: core-foundation
|
IN: core-foundation
|
||||||
|
|
||||||
TYPEDEF: void* CFAllocatorRef
|
TYPEDEF: void* CFAllocatorRef
|
||||||
|
@ -195,11 +195,22 @@ FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
|
||||||
CFFileDescriptorContext* context
|
CFFileDescriptorContext* context
|
||||||
) ;
|
) ;
|
||||||
|
|
||||||
|
: kCFFileDescriptorReadCallBack 1 ; inline
|
||||||
|
: kCFFileDescriptorWriteCallBack 2 ; inline
|
||||||
|
|
||||||
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
FUNCTION: void CFFileDescriptorEnableCallBacks (
|
||||||
CFFileDescriptorRef f,
|
CFFileDescriptorRef f,
|
||||||
CFOptionFlags callBackTypes
|
CFOptionFlags callBackTypes
|
||||||
) ;
|
) ;
|
||||||
|
|
||||||
|
: enable-all-callbacks ( fd -- )
|
||||||
|
{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
|
||||||
|
CFFileDescriptorEnableCallBacks ;
|
||||||
|
|
||||||
|
: <CFFileDescriptor> ( fd callback -- handle )
|
||||||
|
[ f swap ] [ t swap ] bi* f CFFileDescriptorCreate
|
||||||
|
[ "CFFileDescriptorCreate failed" throw ] unless* ;
|
||||||
|
|
||||||
: load-framework ( name -- )
|
: load-framework ( name -- )
|
||||||
dup <CFBundle> [
|
dup <CFBundle> [
|
||||||
CFBundleLoadExecutable drop
|
CFBundleLoadExecutable drop
|
||||||
|
|
|
@ -3,10 +3,10 @@
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||||
math sequences namespaces make assocs init accessors
|
math sequences namespaces make assocs init accessors
|
||||||
continuations combinators core-foundation
|
continuations combinators core-foundation
|
||||||
core-foundation.run-loop core-foundation.run-loop.thread
|
core-foundation.run-loop io.encodings.utf8 destructors locals
|
||||||
io.encodings.utf8 destructors locals arrays
|
arrays specialized-arrays.direct.alien
|
||||||
specialized-arrays.direct.alien specialized-arrays.direct.int
|
specialized-arrays.direct.int specialized-arrays.direct.longlong
|
||||||
specialized-arrays.direct.longlong ;
|
;
|
||||||
IN: core-foundation.fsevents
|
IN: core-foundation.fsevents
|
||||||
|
|
||||||
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
|
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
|
||||||
|
@ -118,7 +118,7 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
|
||||||
FSEventStreamCreate ;
|
FSEventStreamCreate ;
|
||||||
|
|
||||||
: kCFRunLoopCommonModes ( -- string )
|
: kCFRunLoopCommonModes ( -- string )
|
||||||
"kCFRunLoopCommonModes" f dlsym *void* ;
|
&: kCFRunLoopCommonModes *void* ;
|
||||||
|
|
||||||
: schedule-event-stream ( event-stream -- )
|
: schedule-event-stream ( event-stream -- )
|
||||||
CFRunLoopGetMain
|
CFRunLoopGetMain
|
||||||
|
|
|
@ -32,6 +32,12 @@ FUNCTION: void CFRunLoopAddSource (
|
||||||
CFStringRef mode
|
CFStringRef mode
|
||||||
) ;
|
) ;
|
||||||
|
|
||||||
|
FUNCTION: void CFRunLoopRemoveSource (
|
||||||
|
CFRunLoopRef rl,
|
||||||
|
CFRunLoopSourceRef source,
|
||||||
|
CFStringRef mode
|
||||||
|
) ;
|
||||||
|
|
||||||
: CFRunLoopDefaultMode ( -- alien )
|
: CFRunLoopDefaultMode ( -- alien )
|
||||||
#! Ugly, but we don't have static NSStrings
|
#! Ugly, but we don't have static NSStrings
|
||||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||||
|
|
|
@ -1 +0,0 @@
|
||||||
Vocabulary with init hook for running CoreFoundation event loop
|
|
|
@ -1,16 +0,0 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: calendar core-foundation.run-loop init kernel threads ;
|
|
||||||
IN: core-foundation.run-loop.thread
|
|
||||||
|
|
||||||
! Load this vocabulary if you need a run loop running.
|
|
||||||
|
|
||||||
: run-loop-thread ( -- )
|
|
||||||
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
|
|
||||||
kCFRunLoopRunHandledSource = [ 1 seconds sleep ] unless
|
|
||||||
run-loop-thread ;
|
|
||||||
|
|
||||||
: start-run-loop-thread ( -- )
|
|
||||||
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
|
|
||||||
|
|
||||||
[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook
|
|
|
@ -2,12 +2,13 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types alien.strings alien.syntax kernel
|
USING: alien alien.c-types alien.strings alien.syntax kernel
|
||||||
layouts sequences system unix environment io.encodings.utf8
|
layouts sequences system unix environment io.encodings.utf8
|
||||||
unix.utilities vocabs.loader combinators alien.accessors ;
|
unix.utilities vocabs.loader combinators alien.accessors
|
||||||
|
alien.syntax ;
|
||||||
IN: environment.unix
|
IN: environment.unix
|
||||||
|
|
||||||
HOOK: environ os ( -- void* )
|
HOOK: environ os ( -- void* )
|
||||||
|
|
||||||
M: unix environ ( -- void* ) "environ" f dlsym ;
|
M: unix environ ( -- void* ) &: environ ;
|
||||||
|
|
||||||
M: unix os-env ( key -- value ) getenv ;
|
M: unix os-env ( key -- value ) getenv ;
|
||||||
|
|
||||||
|
|
|
@ -7,6 +7,7 @@ math.order hashtables byte-arrays destructors
|
||||||
io.encodings
|
io.encodings
|
||||||
io.encodings.string
|
io.encodings.string
|
||||||
io.encodings.ascii
|
io.encodings.ascii
|
||||||
|
io.encodings.utf8
|
||||||
io.encodings.8-bit
|
io.encodings.8-bit
|
||||||
io.encodings.binary
|
io.encodings.binary
|
||||||
io.streams.duplex
|
io.streams.duplex
|
||||||
|
@ -40,11 +41,11 @@ GENERIC: >post-data ( object -- post-data )
|
||||||
|
|
||||||
M: post-data >post-data ;
|
M: post-data >post-data ;
|
||||||
|
|
||||||
M: string >post-data "application/octet-stream" <post-data> ;
|
M: string >post-data utf8 encode "application/octet-stream" <post-data> ;
|
||||||
|
|
||||||
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
M: byte-array >post-data "application/octet-stream" <post-data> ;
|
||||||
|
|
||||||
M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
|
M: assoc >post-data assoc>query ascii encode "application/x-www-form-urlencoded" <post-data> ;
|
||||||
|
|
||||||
M: f >post-data ;
|
M: f >post-data ;
|
||||||
|
|
||||||
|
@ -52,12 +53,13 @@ M: f >post-data ;
|
||||||
[ >post-data ] change-post-data ;
|
[ >post-data ] change-post-data ;
|
||||||
|
|
||||||
: write-post-data ( request -- request )
|
: write-post-data ( request -- request )
|
||||||
dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
|
dup method>> [ "POST" = ] [ "PUT" = ] bi or [ dup post-data>> raw>> write ] when ;
|
||||||
|
|
||||||
: write-request ( request -- )
|
: write-request ( request -- )
|
||||||
unparse-post-data
|
unparse-post-data
|
||||||
write-request-line
|
write-request-line
|
||||||
write-request-header
|
write-request-header
|
||||||
|
binary encode-output
|
||||||
write-post-data
|
write-post-data
|
||||||
flush
|
flush
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -153,7 +155,7 @@ SYMBOL: redirects
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: success? ( code -- ? ) 200 = ;
|
: success? ( code -- ? ) 200 299 between? ;
|
||||||
|
|
||||||
ERROR: download-failed response ;
|
ERROR: download-failed response ;
|
||||||
|
|
||||||
|
|
|
@ -143,8 +143,9 @@ HELP: <process-stream>
|
||||||
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
|
||||||
|
|
||||||
HELP: wait-for-process
|
HELP: wait-for-process
|
||||||
{ $values { "process" process } { "status" integer } }
|
{ $values { "process" process } { "status" object } }
|
||||||
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
|
{ $description "If the process is still running, waits for it to exit, otherwise outputs the status code immediately. Can be called multiple times on the same process." }
|
||||||
|
{ $notes "The status code is operating system specific; it may be an integer, or another object (the latter is the case on Unix if the process was killed by a signal). However, one cross-platform behavior code can rely on is that a status code of 0 indicates success." } ;
|
||||||
|
|
||||||
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
|
ARTICLE: "io.launcher.descriptors" "Launch descriptors"
|
||||||
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
|
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."
|
||||||
|
|
|
@ -157,7 +157,7 @@ M: process-failed error.
|
||||||
process>> . ;
|
process>> . ;
|
||||||
|
|
||||||
: wait-for-success ( process -- )
|
: wait-for-success ( process -- )
|
||||||
dup wait-for-process dup zero?
|
dup wait-for-process dup 0 =
|
||||||
[ 2drop ] [ process-failed ] if ;
|
[ 2drop ] [ process-failed ] if ;
|
||||||
|
|
||||||
: try-process ( desc -- )
|
: try-process ( desc -- )
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.c-types generic assocs kernel kernel.private
|
USING: alien alien.c-types alien.syntax generic assocs kernel
|
||||||
math io.ports sequences strings sbufs threads unix
|
kernel.private math io.ports sequences strings sbufs threads
|
||||||
vectors io.buffers io.backend io.encodings math.parser
|
unix vectors io.buffers io.backend io.encodings math.parser
|
||||||
continuations system libc qualified namespaces make io.timeouts
|
continuations system libc qualified namespaces make io.timeouts
|
||||||
io.encodings.utf8 destructors accessors summary combinators
|
io.encodings.utf8 destructors accessors summary combinators
|
||||||
locals unix.time fry ;
|
locals unix.time fry io.unix.multiplexers ;
|
||||||
QUALIFIED: io
|
QUALIFIED: io
|
||||||
IN: io.unix.backend
|
IN: io.unix.backend
|
||||||
|
|
||||||
|
@ -37,38 +37,6 @@ M: fd dispose
|
||||||
|
|
||||||
M: fd handle-fd dup check-disposed fd>> ;
|
M: fd handle-fd dup check-disposed fd>> ;
|
||||||
|
|
||||||
! I/O multiplexers
|
|
||||||
TUPLE: mx fd reads writes ;
|
|
||||||
|
|
||||||
: new-mx ( class -- obj )
|
|
||||||
new
|
|
||||||
H{ } clone >>reads
|
|
||||||
H{ } clone >>writes ; inline
|
|
||||||
|
|
||||||
GENERIC: add-input-callback ( thread fd mx -- )
|
|
||||||
|
|
||||||
M: mx add-input-callback reads>> push-at ;
|
|
||||||
|
|
||||||
GENERIC: add-output-callback ( thread fd mx -- )
|
|
||||||
|
|
||||||
M: mx add-output-callback writes>> push-at ;
|
|
||||||
|
|
||||||
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
|
||||||
|
|
||||||
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
|
||||||
|
|
||||||
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
|
||||||
|
|
||||||
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
|
||||||
|
|
||||||
GENERIC: wait-for-events ( ms mx -- )
|
|
||||||
|
|
||||||
: input-available ( fd mx -- )
|
|
||||||
reads>> delete-at* drop [ resume ] each ;
|
|
||||||
|
|
||||||
: output-available ( fd mx -- )
|
|
||||||
writes>> delete-at* drop [ resume ] each ;
|
|
||||||
|
|
||||||
M: fd cancel-operation ( fd -- )
|
M: fd cancel-operation ( fd -- )
|
||||||
dup disposed>> [ drop ] [
|
dup disposed>> [ drop ] [
|
||||||
fd>>
|
fd>>
|
||||||
|
@ -184,11 +152,11 @@ M: stdin dispose*
|
||||||
M: stdin refill
|
M: stdin refill
|
||||||
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
|
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
|
||||||
|
|
||||||
: control-write-fd ( -- fd ) "control_write" f dlsym *uint ;
|
: control-write-fd ( -- fd ) &: control_write *uint ;
|
||||||
|
|
||||||
: size-read-fd ( -- fd ) "size_read" f dlsym *uint ;
|
: size-read-fd ( -- fd ) &: size_read *uint ;
|
||||||
|
|
||||||
: data-read-fd ( -- fd ) "stdin_read" f dlsym *uint ;
|
: data-read-fd ( -- fd ) &: stdin_read *uint ;
|
||||||
|
|
||||||
: <stdin> ( -- stdin )
|
: <stdin> ( -- stdin )
|
||||||
stdin new
|
stdin new
|
||||||
|
@ -207,10 +175,10 @@ TUPLE: mx-port < port mx ;
|
||||||
: <mx-port> ( mx -- port )
|
: <mx-port> ( mx -- port )
|
||||||
dup fd>> mx-port <port> swap >>mx ;
|
dup fd>> mx-port <port> swap >>mx ;
|
||||||
|
|
||||||
: multiplexer-error ( n -- )
|
: multiplexer-error ( n -- n )
|
||||||
0 < [
|
dup 0 < [
|
||||||
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
||||||
[ (io-error) ] unless
|
[ drop 0 ] [ (io-error) ] if
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: ?flag ( n mask symbol -- n )
|
: ?flag ( n mask symbol -- n )
|
||||||
|
|
|
@ -1,16 +1,12 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: io.unix.bsd
|
|
||||||
USING: namespaces system kernel accessors assocs continuations
|
USING: namespaces system kernel accessors assocs continuations
|
||||||
unix io.backend io.unix.backend io.unix.select ;
|
unix io.backend io.unix.backend io.unix.multiplexers
|
||||||
|
io.unix.multiplexers.kqueue ;
|
||||||
|
IN: io.unix.bsd
|
||||||
|
|
||||||
M: bsd init-io ( -- )
|
M: bsd init-io ( -- )
|
||||||
<select-mx> mx set-global ;
|
<kqueue-mx> mx set-global ;
|
||||||
! <kqueue-mx> kqueue-mx set-global
|
|
||||||
! kqueue-mx get-global <mx-port> <mx-task>
|
|
||||||
! dup io-task-fd
|
|
||||||
! [ mx get-global reads>> set-at ]
|
|
||||||
! [ mx get-global writes>> set-at ] 2bi ;
|
|
||||||
|
|
||||||
! M: bsd (monitor) ( path recursive? mailbox -- )
|
! M: bsd (monitor) ( path recursive? mailbox -- )
|
||||||
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||||
|
|
|
@ -49,7 +49,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
|
||||||
: wait-event ( mx us -- n )
|
: wait-event ( mx us -- n )
|
||||||
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||||
epoll_wait dup multiplexer-error ;
|
epoll_wait multiplexer-error ;
|
||||||
|
|
||||||
: handle-event ( event mx -- )
|
: handle-event ( event mx -- )
|
||||||
[ epoll-event-fd ] dip
|
[ epoll-event-fd ] dip
|
||||||
|
|
|
@ -58,8 +58,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
[
|
[
|
||||||
[ fd>> f 0 ]
|
[ fd>> f 0 ]
|
||||||
[ events>> [ underlying>> ] [ length ] bi ] bi
|
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||||
] dip kevent
|
] dip kevent multiplexer-error ;
|
||||||
dup multiplexer-error ;
|
|
||||||
|
|
||||||
: handle-kevent ( mx kevent -- )
|
: handle-kevent ( mx kevent -- )
|
||||||
[ kevent-ident swap ] [ kevent-filter ] bi {
|
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||||
|
|
|
@ -2,7 +2,8 @@ IN: io.unix.launcher.tests
|
||||||
USING: io.files tools.test io.launcher arrays io namespaces
|
USING: io.files tools.test io.launcher arrays io namespaces
|
||||||
continuations math io.encodings.binary io.encodings.ascii
|
continuations math io.encodings.binary io.encodings.ascii
|
||||||
accessors kernel sequences io.encodings.utf8 destructors
|
accessors kernel sequences io.encodings.utf8 destructors
|
||||||
io.streams.duplex ;
|
io.streams.duplex locals concurrency.promises threads
|
||||||
|
unix.process ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
[ "launcher-test-1" temp-file delete-file ] ignore-errors
|
||||||
|
@ -121,3 +122,17 @@ io.streams.duplex ;
|
||||||
input-stream get contents
|
input-stream get contents
|
||||||
] with-stream
|
] with-stream
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Killed processes were exiting with code 0 on FreeBSD
|
||||||
|
[ f ] [
|
||||||
|
[let | p [ <promise> ]
|
||||||
|
s [ <promise> ] |
|
||||||
|
[
|
||||||
|
"sleep 1000" run-detached
|
||||||
|
[ p fulfill ] [ wait-for-process s fulfill ] bi
|
||||||
|
] in-thread
|
||||||
|
|
||||||
|
p ?promise handle>> 9 kill drop
|
||||||
|
s ?promise 0 =
|
||||||
|
]
|
||||||
|
] unit-test
|
||||||
|
|
|
@ -92,14 +92,16 @@ M: unix kill-process* ( pid -- )
|
||||||
processes get swap [ nip swap handle>> = ] curry
|
processes get swap [ nip swap handle>> = ] curry
|
||||||
assoc-find 2drop ;
|
assoc-find 2drop ;
|
||||||
|
|
||||||
|
TUPLE: signal n ;
|
||||||
|
|
||||||
|
: code>status ( code -- obj )
|
||||||
|
dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
|
||||||
|
|
||||||
M: unix wait-for-processes ( -- ? )
|
M: unix wait-for-processes ( -- ? )
|
||||||
-1 0 <int> tuck WNOHANG waitpid
|
-1 0 <int> tuck WNOHANG waitpid
|
||||||
dup 0 <= [
|
dup 0 <= [
|
||||||
2drop t
|
2drop t
|
||||||
] [
|
] [
|
||||||
find-process dup [
|
find-process dup
|
||||||
swap *int WEXITSTATUS notify-exit f
|
[ swap *int code>status notify-exit f ] [ 2drop f ] if
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel io.backend io.monitors io.unix.backend
|
USING: kernel system namespaces io.backend io.unix.backend
|
||||||
io.unix.epoll io.unix.linux.monitors system namespaces ;
|
io.unix.multiplexers io.unix.multiplexers.epoll ;
|
||||||
IN: io.unix.linux
|
IN: io.unix.linux
|
||||||
|
|
||||||
M: linux init-io ( -- )
|
M: linux init-io ( -- )
|
||||||
|
|
|
@ -2,10 +2,10 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||||
io.files io.buffers io.monitors io.ports io.timeouts
|
io.files io.buffers io.monitors io.ports io.timeouts
|
||||||
io.unix.backend io.unix.select io.encodings.utf8
|
io.unix.backend io.encodings.utf8 unix.linux.inotify assocs
|
||||||
unix.linux.inotify assocs namespaces make threads continuations
|
namespaces make threads continuations init math math.bitwise
|
||||||
init math math.bitwise sets alien alien.strings alien.c-types
|
sets alien alien.strings alien.c-types vocabs.loader accessors
|
||||||
vocabs.loader accessors system hashtables destructors unix ;
|
system hashtables destructors unix ;
|
||||||
IN: io.unix.linux.monitors
|
IN: io.unix.linux.monitors
|
||||||
|
|
||||||
SYMBOL: watches
|
SYMBOL: watches
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: io.backend system namespaces io.unix.multiplexers
|
||||||
|
io.unix.multiplexers.run-loop ;
|
||||||
IN: io.unix.macosx
|
IN: io.unix.macosx
|
||||||
USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
|
|
||||||
namespaces system ;
|
|
||||||
|
|
||||||
M: macosx init-io ( -- )
|
M: macosx init-io ( -- )
|
||||||
<kqueue-mx> mx set-global ;
|
<run-loop-mx> mx set-global ;
|
||||||
|
|
||||||
macosx set-io-backend
|
macosx set-io-backend
|
||||||
|
|
0
basis/core-foundation/run-loop/thread/authors.txt → basis/io/unix/multiplexers/epoll/authors.txt
Normal file → Executable file
0
basis/core-foundation/run-loop/thread/authors.txt → basis/io/unix/multiplexers/epoll/authors.txt
Normal file → Executable file
|
@ -0,0 +1,66 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors alien.c-types kernel destructors bit-arrays
|
||||||
|
sequences assocs struct-arrays math namespaces locals fry unix
|
||||||
|
unix.linux.epoll unix.time io.ports io.unix.backend
|
||||||
|
io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.epoll
|
||||||
|
|
||||||
|
TUPLE: epoll-mx < mx events ;
|
||||||
|
|
||||||
|
: max-events ( -- n )
|
||||||
|
#! We read up to 256 events at a time. This is an arbitrary
|
||||||
|
#! constant...
|
||||||
|
256 ; inline
|
||||||
|
|
||||||
|
: <epoll-mx> ( -- mx )
|
||||||
|
epoll-mx new-mx
|
||||||
|
max-events epoll_create dup io-error >>fd
|
||||||
|
max-events "epoll-event" <struct-array> >>events ;
|
||||||
|
|
||||||
|
M: epoll-mx dispose fd>> close-file ;
|
||||||
|
|
||||||
|
: make-event ( fd events -- event )
|
||||||
|
"epoll-event" <c-object>
|
||||||
|
[ set-epoll-event-events ] keep
|
||||||
|
[ set-epoll-event-fd ] keep ;
|
||||||
|
|
||||||
|
:: do-epoll-ctl ( fd mx what events -- )
|
||||||
|
mx fd>> what fd fd events make-event epoll_ctl io-error ;
|
||||||
|
|
||||||
|
: do-epoll-add ( fd mx events -- )
|
||||||
|
EPOLL_CTL_ADD swap EPOLLONESHOT bitor do-epoll-ctl ;
|
||||||
|
|
||||||
|
: do-epoll-del ( fd mx events -- )
|
||||||
|
EPOLL_CTL_DEL swap do-epoll-ctl ;
|
||||||
|
|
||||||
|
M: epoll-mx add-input-callback ( thread fd mx -- )
|
||||||
|
[ EPOLLIN do-epoll-add ] [ call-next-method ] 2bi ;
|
||||||
|
|
||||||
|
M: epoll-mx add-output-callback ( thread fd mx -- )
|
||||||
|
[ EPOLLOUT do-epoll-add ] [ call-next-method ] 2bi ;
|
||||||
|
|
||||||
|
M: epoll-mx remove-input-callbacks ( fd mx -- seq )
|
||||||
|
2dup reads>> key? [
|
||||||
|
[ call-next-method ] [ EPOLLIN do-epoll-del ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: epoll-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
2dup writes>> key? [
|
||||||
|
[ EPOLLOUT do-epoll-del ] [ call-next-method ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: wait-event ( mx us -- n )
|
||||||
|
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
|
||||||
|
epoll_wait multiplexer-error ;
|
||||||
|
|
||||||
|
: handle-event ( event mx -- )
|
||||||
|
[ epoll-event-fd ] dip
|
||||||
|
[ EPOLLIN EPOLLOUT bitor do-epoll-del ]
|
||||||
|
[ input-available ] [ output-available ] 2tri ;
|
||||||
|
|
||||||
|
: handle-events ( mx n -- )
|
||||||
|
[ dup events>> ] dip head-slice swap '[ _ handle-event ] each ;
|
||||||
|
|
||||||
|
M: epoll-mx wait-for-events ( us mx -- )
|
||||||
|
swap 60000000 or dupd wait-event handle-events ;
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,76 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors alien.c-types combinators destructors
|
||||||
|
io.unix.backend kernel math.bitwise sequences struct-arrays unix
|
||||||
|
unix.kqueue unix.time assocs io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.kqueue
|
||||||
|
|
||||||
|
TUPLE: kqueue-mx < mx events ;
|
||||||
|
|
||||||
|
: max-events ( -- n )
|
||||||
|
#! We read up to 256 events at a time. This is an arbitrary
|
||||||
|
#! constant...
|
||||||
|
256 ; inline
|
||||||
|
|
||||||
|
: <kqueue-mx> ( -- mx )
|
||||||
|
kqueue-mx new-mx
|
||||||
|
kqueue dup io-error >>fd
|
||||||
|
max-events "kevent" <struct-array> >>events ;
|
||||||
|
|
||||||
|
M: kqueue-mx dispose fd>> close-file ;
|
||||||
|
|
||||||
|
: make-kevent ( fd filter flags -- event )
|
||||||
|
"kevent" <c-object>
|
||||||
|
[ set-kevent-flags ] keep
|
||||||
|
[ set-kevent-filter ] keep
|
||||||
|
[ set-kevent-ident ] keep ;
|
||||||
|
|
||||||
|
: register-kevent ( kevent mx -- )
|
||||||
|
fd>> swap 1 f 0 f kevent io-error ;
|
||||||
|
|
||||||
|
M: kqueue-mx add-input-callback ( thread fd mx -- )
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi ;
|
||||||
|
|
||||||
|
M: kqueue-mx add-output-callback ( thread fd mx -- )
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi ;
|
||||||
|
|
||||||
|
M: kqueue-mx remove-input-callbacks ( fd mx -- seq )
|
||||||
|
2dup reads>> key? [
|
||||||
|
[ call-next-method ] [
|
||||||
|
[ EVFILT_READ EV_DELETE make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
|
||||||
|
2dup writes>> key? [
|
||||||
|
[
|
||||||
|
[ EVFILT_WRITE EV_DELETE make-kevent ] dip
|
||||||
|
register-kevent
|
||||||
|
] [ call-next-method ] 2bi
|
||||||
|
] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
: wait-kevent ( mx timespec -- n )
|
||||||
|
[
|
||||||
|
[ fd>> f 0 ]
|
||||||
|
[ events>> [ underlying>> ] [ length ] bi ] bi
|
||||||
|
] dip kevent multiplexer-error ;
|
||||||
|
|
||||||
|
: handle-kevent ( mx kevent -- )
|
||||||
|
[ kevent-ident swap ] [ kevent-filter ] bi {
|
||||||
|
{ EVFILT_READ [ input-available ] }
|
||||||
|
{ EVFILT_WRITE [ output-available ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: handle-kevents ( mx n -- )
|
||||||
|
[ dup events>> ] dip head-slice [ handle-kevent ] with each ;
|
||||||
|
|
||||||
|
M: kqueue-mx wait-for-events ( us mx -- )
|
||||||
|
swap dup [ make-timespec ] when
|
||||||
|
dupd wait-kevent handle-kevents ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1,35 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel accessors assocs sequences threads ;
|
||||||
|
IN: io.unix.multiplexers
|
||||||
|
|
||||||
|
TUPLE: mx fd reads writes ;
|
||||||
|
|
||||||
|
: new-mx ( class -- obj )
|
||||||
|
new
|
||||||
|
H{ } clone >>reads
|
||||||
|
H{ } clone >>writes ; inline
|
||||||
|
|
||||||
|
GENERIC: add-input-callback ( thread fd mx -- )
|
||||||
|
|
||||||
|
M: mx add-input-callback reads>> push-at ;
|
||||||
|
|
||||||
|
GENERIC: add-output-callback ( thread fd mx -- )
|
||||||
|
|
||||||
|
M: mx add-output-callback writes>> push-at ;
|
||||||
|
|
||||||
|
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
||||||
|
|
||||||
|
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
||||||
|
|
||||||
|
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
||||||
|
|
||||||
|
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
||||||
|
|
||||||
|
GENERIC: wait-for-events ( ms mx -- )
|
||||||
|
|
||||||
|
: input-available ( fd mx -- )
|
||||||
|
reads>> delete-at* drop [ resume ] each ;
|
||||||
|
|
||||||
|
: output-available ( fd mx -- )
|
||||||
|
writes>> delete-at* drop [ resume ] each ;
|
|
@ -0,0 +1,57 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel namespaces math accessors threads alien locals
|
||||||
|
destructors combinators core-foundation core-foundation.run-loop
|
||||||
|
io.unix.multiplexers io.unix.multiplexers.kqueue ;
|
||||||
|
IN: io.unix.multiplexers.run-loop
|
||||||
|
|
||||||
|
TUPLE: run-loop-mx kqueue-mx fd source ;
|
||||||
|
|
||||||
|
: kqueue-callback ( -- callback )
|
||||||
|
"void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
|
||||||
|
"cdecl" [
|
||||||
|
3drop
|
||||||
|
0 mx get kqueue-mx>> wait-for-events
|
||||||
|
mx get fd>> enable-all-callbacks
|
||||||
|
yield
|
||||||
|
]
|
||||||
|
alien-callback ;
|
||||||
|
|
||||||
|
SYMBOL: kqueue-run-loop-source
|
||||||
|
|
||||||
|
: create-kqueue-source ( fd -- source )
|
||||||
|
f swap 0 CFFileDescriptorCreateRunLoopSource ;
|
||||||
|
|
||||||
|
: add-kqueue-to-run-loop ( mx -- )
|
||||||
|
CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopAddSource ;
|
||||||
|
|
||||||
|
: remove-kqueue-from-run-loop ( source -- )
|
||||||
|
CFRunLoopGetMain swap source>> CFRunLoopDefaultMode CFRunLoopRemoveSource ;
|
||||||
|
|
||||||
|
: <run-loop-mx> ( -- mx )
|
||||||
|
[
|
||||||
|
<kqueue-mx> |dispose
|
||||||
|
dup fd>> kqueue-callback <CFFileDescriptor> |dispose
|
||||||
|
dup create-kqueue-source run-loop-mx boa
|
||||||
|
dup add-kqueue-to-run-loop
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
|
M: run-loop-mx dispose
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ fd>> &dispose drop ]
|
||||||
|
[ source>> &dispose drop ]
|
||||||
|
[ remove-kqueue-from-run-loop ]
|
||||||
|
[ kqueue-mx>> &dispose drop ]
|
||||||
|
} cleave
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
|
M: run-loop-mx add-input-callback kqueue-mx>> add-input-callback ;
|
||||||
|
M: run-loop-mx add-output-callback kqueue-mx>> add-output-callback ;
|
||||||
|
M: run-loop-mx remove-input-callbacks kqueue-mx>> remove-input-callbacks ;
|
||||||
|
M: run-loop-mx remove-output-callbacks kqueue-mx>> remove-output-callbacks ;
|
||||||
|
|
||||||
|
M:: run-loop-mx wait-for-events ( us mx -- )
|
||||||
|
mx fd>> enable-all-callbacks
|
||||||
|
CFRunLoopDefaultMode us [ 1000000 /f ] [ 60 ] if* t CFRunLoopRunInMode
|
||||||
|
kCFRunLoopRunHandledSource = [ 0 mx wait-for-events ] when ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1 @@
|
||||||
|
Slava Pestov
|
|
@ -0,0 +1,56 @@
|
||||||
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: alien.c-types kernel bit-arrays sequences assocs unix
|
||||||
|
math namespaces accessors math.order locals unix.time fry
|
||||||
|
io.ports io.unix.backend io.unix.multiplexers ;
|
||||||
|
IN: io.unix.multiplexers.select
|
||||||
|
|
||||||
|
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||||
|
|
||||||
|
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||||
|
! FD_SET to be an array of cells, so we have to account for
|
||||||
|
! byte order differences on big endian platforms
|
||||||
|
: munge ( i -- i' )
|
||||||
|
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||||
|
|
||||||
|
: <select-mx> ( -- mx )
|
||||||
|
select-mx new-mx
|
||||||
|
FD_SETSIZE 8 * <bit-array> >>read-fdset
|
||||||
|
FD_SETSIZE 8 * <bit-array> >>write-fdset ;
|
||||||
|
|
||||||
|
: clear-nth ( n seq -- ? )
|
||||||
|
[ nth ] [ [ f ] 2dip set-nth ] 2bi ;
|
||||||
|
|
||||||
|
:: check-fd ( fd fdset mx quot -- )
|
||||||
|
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
|
||||||
|
|
||||||
|
: check-fdset ( fds fdset mx quot -- )
|
||||||
|
[ check-fd ] 3curry each ; inline
|
||||||
|
|
||||||
|
: init-fdset ( fds fdset -- )
|
||||||
|
'[ t swap munge _ set-nth ] each ;
|
||||||
|
|
||||||
|
: read-fdset/tasks ( mx -- seq fdset )
|
||||||
|
[ reads>> keys ] [ read-fdset>> ] bi ;
|
||||||
|
|
||||||
|
: write-fdset/tasks ( mx -- seq fdset )
|
||||||
|
[ writes>> keys ] [ write-fdset>> ] bi ;
|
||||||
|
|
||||||
|
: max-fd ( assoc -- n )
|
||||||
|
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||||
|
|
||||||
|
: num-fds ( mx -- n )
|
||||||
|
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||||
|
|
||||||
|
: init-fdsets ( mx -- nfds read write except )
|
||||||
|
[ num-fds ]
|
||||||
|
[ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
|
||||||
|
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
|
||||||
|
f ;
|
||||||
|
|
||||||
|
M:: select-mx wait-for-events ( us mx -- )
|
||||||
|
mx
|
||||||
|
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
|
||||||
|
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||||
|
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||||
|
tri ;
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -50,7 +50,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||||
|
|
||||||
M:: select-mx wait-for-events ( us mx -- )
|
M:: select-mx wait-for-events ( us mx -- )
|
||||||
mx
|
mx
|
||||||
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error ]
|
[ init-fdsets us dup [ make-timeval ] when select multiplexer-error drop ]
|
||||||
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||||
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
|
@ -3,11 +3,11 @@ USING: help.markup help.syntax sequences.private ;
|
||||||
|
|
||||||
HELP: disassemble
|
HELP: disassemble
|
||||||
{ $values { "obj" "a word or a pair of addresses" } }
|
{ $values { "obj" "a word or a pair of addresses" } }
|
||||||
{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers) by attaching " { $snippet "gdb" } " to the Factor VM and capturing the output." }
|
{ $description "Disassembles either a compiled word definition or an arbitrary memory range (in the case " { $snippet "obj" } " is a pair of integers)." }
|
||||||
{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse " { $snippet "gdb" } ". This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline. Also on the ARM architecture, various pointers are often compiled inline, and the preceeding instruction jumps over the inline pinter." } ;
|
{ $notes "In some cases the Factor compiler emits data inline with code, which can confuse the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;
|
||||||
|
|
||||||
ARTICLE: "tools.disassembler" "Disassembling words"
|
ARTICLE: "tools.disassembler" "Disassembling words"
|
||||||
"The " { $vocab-link "tools.disassembler" } " vocabulary integrates Factor with the GNU debugger (" { $snippet "gdb" } ") for viewing the assembly code generated by the compiler. It can be used on both Unix and Windows as long as a working copy of " { $snippet "gdb" } " is installed and available in the " { $snippet "PATH" } "."
|
"The " { $vocab-link "tools.disassembler" } " vocabulary provides support for disassembling compiled word definitions. It uses the " { $snippet "libudis86" } " library on x86-32 and x86-64, and " { $snippet "gdb" } " on PowerPC."
|
||||||
{ $subsection disassemble } ;
|
{ $subsection disassemble } ;
|
||||||
|
|
||||||
ABOUT: "tools.disassembler"
|
ABOUT: "tools.disassembler"
|
||||||
|
|
|
@ -1,43 +1,25 @@
|
||||||
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.files io words alien kernel math.parser alien.syntax
|
USING: tr arrays sequences io words generic system combinators
|
||||||
io.launcher system assocs arrays sequences namespaces make
|
vocabs.loader ;
|
||||||
qualified system math compiler.codegen.fixup
|
|
||||||
io.encodings.ascii accessors generic tr ;
|
|
||||||
IN: tools.disassembler
|
IN: tools.disassembler
|
||||||
|
|
||||||
: in-file ( -- path ) "gdb-in.txt" temp-file ;
|
GENERIC: disassemble ( obj -- )
|
||||||
|
|
||||||
: out-file ( -- path ) "gdb-out.txt" temp-file ;
|
SYMBOL: disassembler-backend
|
||||||
|
|
||||||
GENERIC: make-disassemble-cmd ( obj -- )
|
HOOK: disassemble* disassembler-backend ( from to -- lines )
|
||||||
|
|
||||||
M: word make-disassemble-cmd
|
|
||||||
word-xt code-format - 2array make-disassemble-cmd ;
|
|
||||||
|
|
||||||
M: pair make-disassemble-cmd
|
|
||||||
in-file ascii [
|
|
||||||
"attach " write
|
|
||||||
current-process-handle number>string print
|
|
||||||
"disassemble " write
|
|
||||||
[ number>string write bl ] each
|
|
||||||
] with-file-writer ;
|
|
||||||
|
|
||||||
M: method-spec make-disassemble-cmd
|
|
||||||
first2 method make-disassemble-cmd ;
|
|
||||||
|
|
||||||
: gdb-binary ( -- string ) "gdb" ;
|
|
||||||
|
|
||||||
: run-gdb ( -- lines )
|
|
||||||
<process>
|
|
||||||
+closed+ >>stdin
|
|
||||||
out-file >>stdout
|
|
||||||
[ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
|
|
||||||
try-process
|
|
||||||
out-file ascii file-lines ;
|
|
||||||
|
|
||||||
TR: tabs>spaces "\t" "\s" ;
|
TR: tabs>spaces "\t" "\s" ;
|
||||||
|
|
||||||
: disassemble ( obj -- )
|
M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
|
||||||
make-disassemble-cmd run-gdb
|
|
||||||
[ tabs>spaces ] map [ print ] each ;
|
M: word disassemble word-xt 2array disassemble ;
|
||||||
|
|
||||||
|
M: method-spec disassemble first2 method disassemble ;
|
||||||
|
|
||||||
|
cpu {
|
||||||
|
{ x86.32 [ "tools.disassembler.udis" ] }
|
||||||
|
{ x86.64 [ "tools.disassembler.udis" ] }
|
||||||
|
{ ppc [ "tools.disassembler.gdb" ] }
|
||||||
|
} case require
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: io.files io words alien kernel math.parser alien.syntax
|
||||||
|
io.launcher system assocs arrays sequences namespaces make
|
||||||
|
qualified system math io.encodings.ascii accessors
|
||||||
|
tools.disassembler ;
|
||||||
|
IN: tools.disassembler.gdb
|
||||||
|
|
||||||
|
SINGLETON: gdb-disassembler
|
||||||
|
|
||||||
|
: in-file ( -- path ) "gdb-in.txt" temp-file ;
|
||||||
|
|
||||||
|
: out-file ( -- path ) "gdb-out.txt" temp-file ;
|
||||||
|
|
||||||
|
: make-disassemble-cmd ( from to -- )
|
||||||
|
in-file ascii [
|
||||||
|
"attach " write
|
||||||
|
current-process-handle number>string print
|
||||||
|
"disassemble " write
|
||||||
|
[ number>string write bl ] bi@
|
||||||
|
] with-file-writer ;
|
||||||
|
|
||||||
|
: gdb-binary ( -- string ) "gdb" ;
|
||||||
|
|
||||||
|
: run-gdb ( -- lines )
|
||||||
|
<process>
|
||||||
|
+closed+ >>stdin
|
||||||
|
out-file >>stdout
|
||||||
|
[ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
|
||||||
|
try-process
|
||||||
|
out-file ascii file-lines ;
|
||||||
|
|
||||||
|
M: gdb-disassembler disassemble*
|
||||||
|
make-disassemble-cmd run-gdb ;
|
||||||
|
|
||||||
|
gdb-disassembler disassembler-backend set-global
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1 @@
|
||||||
|
unportable
|
|
@ -0,0 +1,89 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: tools.disassembler namespaces combinators
|
||||||
|
alien alien.syntax alien.c-types lexer parser kernel
|
||||||
|
sequences layouts math math.parser system make fry arrays ;
|
||||||
|
IN: tools.disassembler.udis
|
||||||
|
|
||||||
|
<<
|
||||||
|
"libudis86" {
|
||||||
|
{ [ os macosx? ] [ "libudis86.0.dylib" ] }
|
||||||
|
{ [ os unix? ] [ "libudis86.so.0" ] }
|
||||||
|
{ [ os winnt? ] [ "libudis86.dll" ] }
|
||||||
|
} cond "cdecl" add-library
|
||||||
|
>>
|
||||||
|
|
||||||
|
LIBRARY: libudis86
|
||||||
|
|
||||||
|
TYPEDEF: char[592] ud
|
||||||
|
|
||||||
|
FUNCTION: void ud_translate_intel ( ud* u ) ;
|
||||||
|
FUNCTION: void ud_translate_att ( ud* u ) ;
|
||||||
|
|
||||||
|
: UD_SYN_INTEL &: ud_translate_intel ; inline
|
||||||
|
: UD_SYN_ATT &: ud_translate_att ; inline
|
||||||
|
: UD_EOI -1 ; inline
|
||||||
|
: UD_INP_CACHE_SZ 32 ; inline
|
||||||
|
: UD_VENDOR_AMD 0 ; inline
|
||||||
|
: UD_VENDOR_INTEL 1 ; inline
|
||||||
|
|
||||||
|
FUNCTION: void ud_init ( ud* u ) ;
|
||||||
|
FUNCTION: void ud_set_mode ( ud* u, uint8_t mode ) ;
|
||||||
|
FUNCTION: void ud_set_pc ( ud* u, ulonglong pc ) ;
|
||||||
|
FUNCTION: void ud_set_input_buffer ( ud* u, uint8_t* offset, size_t size ) ;
|
||||||
|
FUNCTION: void ud_set_vendor ( ud* u, uint vendor ) ;
|
||||||
|
FUNCTION: void ud_set_syntax ( ud* u, void* syntax ) ;
|
||||||
|
FUNCTION: void ud_input_skip ( ud* u, size_t size ) ;
|
||||||
|
FUNCTION: int ud_input_end ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_decode ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_disassemble ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_insn_asm ( ud* u ) ;
|
||||||
|
FUNCTION: void* ud_insn_ptr ( ud* u ) ;
|
||||||
|
FUNCTION: ulonglong ud_insn_off ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_insn_hex ( ud* u ) ;
|
||||||
|
FUNCTION: uint ud_insn_len ( ud* u ) ;
|
||||||
|
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
|
||||||
|
|
||||||
|
: <ud> ( -- ud )
|
||||||
|
"ud" <c-object>
|
||||||
|
dup ud_init
|
||||||
|
dup cell-bits ud_set_mode
|
||||||
|
dup UD_SYN_INTEL ud_set_syntax ;
|
||||||
|
|
||||||
|
SINGLETON: udis-disassembler
|
||||||
|
|
||||||
|
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
|
||||||
|
|
||||||
|
: format-disassembly ( lines -- lines' )
|
||||||
|
dup [ second length ] map supremum
|
||||||
|
'[
|
||||||
|
[
|
||||||
|
[ first >hex cell 2 * CHAR: 0 pad-left % ": " % ]
|
||||||
|
[ second _ CHAR: \s pad-right % " " % ]
|
||||||
|
[ third % ]
|
||||||
|
tri
|
||||||
|
] "" make
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: (disassemble) ( ud -- lines )
|
||||||
|
[
|
||||||
|
dup '[
|
||||||
|
_ ud_disassemble 0 =
|
||||||
|
[ f ] [
|
||||||
|
_
|
||||||
|
[ ud_insn_off ]
|
||||||
|
[ ud_insn_hex ]
|
||||||
|
[ ud_insn_asm ]
|
||||||
|
tri 3array , t
|
||||||
|
] if
|
||||||
|
] loop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
M: udis-disassembler disassemble* ( from to -- buffer )
|
||||||
|
[ <ud> ] 2dip {
|
||||||
|
[ drop ud_set_pc ]
|
||||||
|
[ buf/len ud_set_input_buffer ]
|
||||||
|
[ 2drop (disassemble) format-disassembly ]
|
||||||
|
} 3cleave ;
|
||||||
|
|
||||||
|
udis-disassembler disassembler-backend set-global
|
|
@ -2,6 +2,10 @@ USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
|
||||||
help.syntax models opengl strings ;
|
help.syntax models opengl strings ;
|
||||||
IN: ui.gadgets.worlds
|
IN: ui.gadgets.worlds
|
||||||
|
|
||||||
|
HELP: user-input
|
||||||
|
{ $values { "string" string } { "world" world } }
|
||||||
|
{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ;
|
||||||
|
|
||||||
HELP: origin
|
HELP: origin
|
||||||
{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
|
{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
|
||||||
|
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: ui.gadgets help.markup help.syntax hashtables
|
USING: ui.gadgets ui.gadgets.worlds help.markup help.syntax
|
||||||
strings kernel system ;
|
hashtables strings kernel system ;
|
||||||
IN: ui.gestures
|
IN: ui.gestures
|
||||||
|
|
||||||
HELP: set-gestures
|
HELP: set-gestures
|
||||||
|
@ -21,10 +21,6 @@ HELP: propagate-gesture
|
||||||
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
|
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
|
||||||
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
|
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
|
||||||
|
|
||||||
HELP: user-input
|
|
||||||
{ $values { "string" string } { "gadget" gadget } }
|
|
||||||
{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
|
|
||||||
|
|
||||||
HELP: motion
|
HELP: motion
|
||||||
{ $class-description "Mouse motion gesture." }
|
{ $class-description "Mouse motion gesture." }
|
||||||
{ $examples { $code "T{ motion }" } } ;
|
{ $examples { $code "T{ motion }" } } ;
|
||||||
|
|
|
@ -137,7 +137,7 @@ M: world focus-out-event
|
||||||
|
|
||||||
M: world selection-notify-event
|
M: world selection-notify-event
|
||||||
[ handle>> window>> selection-from-event ] keep
|
[ handle>> window>> selection-from-event ] keep
|
||||||
world user-input ;
|
user-input ;
|
||||||
|
|
||||||
: supported-type? ( atom -- ? )
|
: supported-type? ( atom -- ? )
|
||||||
{ "UTF8_STRING" "STRING" "TEXT" }
|
{ "UTF8_STRING" "STRING" "TEXT" }
|
||||||
|
|
|
@ -74,7 +74,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
|
||||||
HEX: 7f bitand ; inline
|
HEX: 7f bitand ; inline
|
||||||
|
|
||||||
: WIFEXITED ( status -- ? )
|
: WIFEXITED ( status -- ? )
|
||||||
WTERMSIG zero? ; inline
|
WTERMSIG 0 = ; inline
|
||||||
|
|
||||||
: WEXITSTATUS ( status -- value )
|
: WEXITSTATUS ( status -- value )
|
||||||
HEX: ff00 bitand -8 shift ; inline
|
HEX: ff00 bitand -8 shift ; inline
|
||||||
|
@ -86,7 +86,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
|
||||||
HEX: 80 ; inline
|
HEX: 80 ; inline
|
||||||
|
|
||||||
: WCOREDUMP ( status -- ? )
|
: WCOREDUMP ( status -- ? )
|
||||||
WCOREFLAG bitand zero? not ; inline
|
WCOREFLAG bitand 0 = not ; inline
|
||||||
|
|
||||||
: WIFSTOPPED ( status -- ? )
|
: WIFSTOPPED ( status -- ? )
|
||||||
HEX: ff bitand HEX: 7f = ; inline
|
HEX: ff bitand HEX: 7f = ; inline
|
||||||
|
|
|
@ -343,7 +343,7 @@ PRIVATE>
|
||||||
[ (each) ] dip collect ; inline
|
[ (each) ] dip collect ; inline
|
||||||
|
|
||||||
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
|
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
|
||||||
[ over ] dip nth-unsafe [ nth-unsafe ] dip ; inline
|
[ over ] dip [ nth-unsafe ] 2bi@ ; inline
|
||||||
|
|
||||||
: (2each) ( seq1 seq2 quot -- n quot' )
|
: (2each) ( seq1 seq2 quot -- n quot' )
|
||||||
[ [ min-length ] 2keep ] dip
|
[ [ min-length ] 2keep ] dip
|
||||||
|
@ -538,12 +538,12 @@ M: sequence <=>
|
||||||
|
|
||||||
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
: sequence-hashcode-step ( oldhash newpart -- newhash )
|
||||||
>fixnum swap [
|
>fixnum swap [
|
||||||
dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
|
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
|
||||||
fixnum+fast fixnum+fast
|
fixnum+fast fixnum+fast
|
||||||
] keep fixnum-bitxor ; inline
|
] keep fixnum-bitxor ; inline
|
||||||
|
|
||||||
: sequence-hashcode ( n seq -- x )
|
: sequence-hashcode ( n seq -- x )
|
||||||
0 -rot [ hashcode* sequence-hashcode-step ] with each ; inline
|
[ 0 ] 2dip [ hashcode* sequence-hashcode-step ] with each ; inline
|
||||||
|
|
||||||
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
|
M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue