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

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

db4
Joe Groff 2008-12-11 17:16:12 -08:00
parent e795571639 c679ae025b
commit ed45192b6d
38 changed files with 346 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/c-types/c-types-tests.factor
View File

@ -8,7 +8,7 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
: foo ( -- n ) &: fdafd [ 123 ] unless* ;
[ 123 ] [ foo ] unit-test

5
basis/alien/syntax/syntax-docs.factor
View File

@ -77,6 +77,11 @@ HELP: C-ENUM:
{ $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
{ $values { "old" "a string" } { "new" "a string" } }
{ $description "Alises the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }

7
basis/alien/syntax/syntax.factor
View File

@ -3,7 +3,8 @@
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
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
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@ -33,3 +34,7 @@ IN: alien.syntax
dup length
[ [ create-in ] dip 1quotation define ] 2each ;
parsing
: &:
scan "c-library" get
'[ _ _ load-library dlsym ] over push-all ; parsing

6
basis/compiler/tests/alien.factor
View File

@ -83,14 +83,14 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 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 -- )
"int" { } "cdecl" alien-indirect drop ;
{ 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
@ -100,7 +100,7 @@ FUNCTION: tiny ffi_test_17 int x ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
[ 2 3 &: ffi_test_2 indirect-test-2 ]
unit-test
: indirect-test-3 ( a b c d ptr -- result )

2
basis/core-foundation/fsevents/fsevents.factor
View File

@ -118,7 +118,7 @@ FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef
FSEventStreamCreate ;
: kCFRunLoopCommonModes ( -- string )
"kCFRunLoopCommonModes" f dlsym *void* ;
&: kCFRunLoopCommonModes *void* ;
: schedule-event-stream ( event-stream -- )
CFRunLoopGetMain

5
basis/environment/unix/unix.factor
View File

@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax kernel
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
HOOK: environ os ( -- void* )
M: unix environ ( -- void* ) "environ" f dlsym ;
M: unix environ ( -- void* ) &: environ ;
M: unix os-env ( key -- value ) getenv ;

10
basis/http/client/client.factor
View File

@ -7,6 +7,7 @@ math.order hashtables byte-arrays destructors
io.encodings
io.encodings.string
io.encodings.ascii
io.encodings.utf8
io.encodings.8-bit
io.encodings.binary
io.streams.duplex
@ -40,11 +41,11 @@ GENERIC: >post-data ( object -- 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: 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 ;
@ -52,12 +53,13 @@ M: f >post-data ;
[ >post-data ] change-post-data ;
: 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 -- )
unparse-post-data
write-request-line
write-request-header
binary encode-output
write-post-data
flush
drop ;
@ -153,7 +155,7 @@ SYMBOL: redirects
PRIVATE>
: success? ( code -- ? ) 200 = ;
: success? ( code -- ? ) 200 299 between? ;
ERROR: download-failed response ;

5
basis/io/launcher/launcher-docs.factor
View File

@ -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." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
{ $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." } ;
{ $values { "process" process } { "status" object } }
{ $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"
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."

2
basis/io/launcher/launcher.factor
View File

@ -157,7 +157,7 @@ M: process-failed error.
process>> . ;
: wait-for-success ( process -- )
dup wait-for-process dup zero?
dup wait-for-process dup 0 =
[ 2drop ] [ process-failed ] if ;
: try-process ( desc -- )

18
basis/io/unix/backend/backend.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types generic assocs kernel kernel.private
math io.ports sequences strings sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
USING: alien alien.c-types alien.syntax generic assocs kernel
kernel.private math io.ports sequences strings sbufs threads
unix 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 fry ;
@ -184,11 +184,11 @@ M: stdin dispose*
M: stdin refill
[ 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 new
@ -207,10 +207,10 @@ TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
dup fd>> mx-port <port> swap >>mx ;
: multiplexer-error ( n -- )
0 < [
: multiplexer-error ( n -- n )
dup 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or
[ (io-error) ] unless
[ drop 0 ] [ (io-error) ] if
] when ;
: ?flag ( n mask symbol -- n )

11
basis/io/unix/bsd/bsd.factor
View File

@ -1,16 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
USING: namespaces system kernel accessors assocs continuations
unix io.backend io.unix.backend io.unix.select ;
unix io.backend io.unix.backend io.unix.kqueue ;
IN: io.unix.bsd
M: bsd init-io ( -- )
<select-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 ;
<kqueue-mx> mx set-global ;
! M: bsd (monitor) ( path recursive? mailbox -- )
! swap [ "Recursive kqueue monitors not supported" throw ] when

2
basis/io/unix/epoll/epoll.factor
View File

@ -49,7 +49,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
: wait-event ( mx us -- n )
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
epoll_wait dup multiplexer-error ;
epoll_wait multiplexer-error ;
: handle-event ( event mx -- )
[ epoll-event-fd ] dip

5
basis/io/unix/files/freebsd/freebsd.factor
View File

@ -3,7 +3,8 @@
USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.unix.files kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 ;
sequences grouping alien.strings io.encodings.utf8
specialized-arrays.direct.uint arrays ;
IN: io.unix.files.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -32,7 +33,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
[ statfs-f_asyncreads >>asyncreads ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
[ statfs-f_fsid >>id ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_fstypename utf8 alien>string >>type ]
[ statfs-f_mntfromname utf8 alien>string >>device-name ]
[ statfs-f_mntonname utf8 alien>string >>mount-point ]

5
basis/io/unix/files/linux/linux.factor
View File

@ -3,7 +3,8 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.streams.string
io.unix.files kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux ;
system unix unix.statfs.linux unix.statvfs.linux
specialized-arrays.direct.uint arrays ;
IN: io.unix.files.linux
TUPLE: linux-file-system-info < unix-file-system-info
@ -23,7 +24,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>id ]
[ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ]
! [ statfs64-f_spare >>spare ]

6
basis/io/unix/files/netbsd/netbsd.factor
View File

@ -3,8 +3,8 @@
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.unix.files
io.files unix.statvfs.netbsd unix.getfsstat.netbsd
grouping sequences io.encodings.utf8 ;
io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ;
IN: io.unix.files.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
@ -35,7 +35,7 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
[ statvfs-f_fsidx >>idx ]
[ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ]

5
basis/io/unix/files/openbsd/openbsd.factor
View File

@ -3,7 +3,8 @@
USING: accessors alien.c-types alien.strings alien.syntax
combinators io.backend io.files io.unix.files kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types ;
unix.statfs.openbsd unix.statvfs.openbsd unix.types
specialized-arrays.direct.uint arrays ;
IN: io.unix.files.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -30,7 +31,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
[ statfs-f_syncreads >>sync-reads ]
[ statfs-f_asyncwrites >>async-writes ]
[ statfs-f_asyncreads >>async-reads ]
[ statfs-f_fsid >>id ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
! [ statfs-f_spare >>spare ]

3
basis/io/unix/kqueue/kqueue.factor
View File

@ -58,8 +58,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
[
[ fd>> f 0 ]
[ events>> [ underlying>> ] [ length ] bi ] bi
] dip kevent
dup multiplexer-error ;
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
[ kevent-ident swap ] [ kevent-filter ] bi {

17
basis/io/unix/launcher/launcher-tests.factor
View File

@ -2,7 +2,8 @@ IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
continuations math io.encodings.binary io.encodings.ascii
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
@ -121,3 +122,17 @@ io.streams.duplex ;
input-stream get contents
] with-stream
] 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

12
basis/io/unix/launcher/launcher.factor
View File

@ -92,14 +92,16 @@ M: unix kill-process* ( pid -- )
processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ;
TUPLE: signal n ;
: code>status ( code -- obj )
dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
] [
find-process dup [
swap *int WEXITSTATUS notify-exit f
] [
2drop f
] if
find-process dup
[ swap *int code>status notify-exit f ] [ 2drop f ] if
] if ;

5
basis/io/unix/macosx/macosx.factor
View File

@ -1,10 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.macosx
USING: io.unix.backend io.unix.bsd io.unix.kqueue io.backend
USING: io.unix.backend io.unix.bsd io.backend
namespaces system ;
M: macosx init-io ( -- )
<kqueue-mx> mx set-global ;
macosx set-io-backend

2
basis/io/unix/select/select.factor
View File

@ -50,7 +50,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
M:: select-mx wait-for-events ( us 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 ]
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;

6
basis/tools/disassembler/disassembler-docs.factor
View File

@ -3,11 +3,11 @@ USING: help.markup help.syntax sequences.private ;
HELP: disassemble
{ $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." }
{ $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." } ;
{ $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 the disassembler. This occurs in words which call " { $link dispatch } ", where the jump table addresses are compiled inline." } ;
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 } ;
ABOUT: "tools.disassembler"

52
basis/tools/disassembler/disassembler.factor
View File

@ -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.
USING: io.files io words alien kernel math.parser alien.syntax
io.launcher system assocs arrays sequences namespaces make
qualified system math compiler.codegen.fixup
io.encodings.ascii accessors generic tr ;
USING: tr arrays sequences io words generic system combinators
vocabs.loader ;
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 -- )
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 ;
HOOK: disassemble* disassembler-backend ( from to -- lines )
TR: tabs>spaces "\t" "\s" ;
: disassemble ( obj -- )
make-disassemble-cmd run-gdb
[ tabs>spaces ] map [ print ] each ;
M: pair disassemble first2 disassemble* [ tabs>spaces 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

36
basis/tools/disassembler/gdb/gdb.factor Normal file
View File

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

1
basis/tools/disassembler/gdb/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/tools/disassembler/udis/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

89
basis/tools/disassembler/udis/udis.factor Normal file
View File

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

21
basis/ui/cocoa/views/views.factor
View File

@ -60,7 +60,7 @@ IN: ui.cocoa.views
dup event-modifiers swap key-code ;
: send-key-event ( view gesture -- )
swap window-focus propagate-gesture ;
swap window propagate-key-gesture ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
@ -266,30 +266,23 @@ CLASS: {
{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
[
CF>string-array NSStringPboardType swap member? [
>r drop window-focus gadget-selection dup [
r> set-pasteboard-string 1
] [
r> 2drop 0
] if
] [
3drop 0
] if
[ drop window-focus gadget-selection ] dip over
[ set-pasteboard-string 1 ] [ 2drop 0 ] if
] [ 3drop 0 ] if
]
}
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
[
pasteboard-string dup [
[ drop window-focus ] dip swap user-input 1
] [
3drop 0
] if
[ drop window ] dip swap user-input 1
] [ 3drop 0 ] if
]
}
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
[ nip CF>string swap window-focus user-input ]
[ nip CF>string swap window user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }

4
basis/ui/gadgets/worlds/worlds-docs.factor
View File

@ -2,6 +2,10 @@ USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
help.syntax models opengl strings ;
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
{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;

8
basis/ui/gestures/gestures-docs.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets help.markup help.syntax hashtables
strings kernel system ;
USING: ui.gadgets ui.gadgets.worlds help.markup help.syntax
hashtables strings kernel system ;
IN: ui.gestures
HELP: set-gestures
@ -21,10 +21,6 @@ HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" 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
{ $class-description "Mouse motion gesture." }
{ $examples { $code "T{ motion }" } } ;

21
basis/ui/gestures/gestures.factor
View File

@ -41,13 +41,25 @@ M: propagate-gesture send-queued-gesture
: propagate-gesture ( gesture gadget -- )
\ propagate-gesture queue-gesture ;
TUPLE: user-input string gadget ;
TUPLE: propagate-key-gesture gesture world ;
: world-focus ( world -- gadget )
dup focus>> [ world-focus ] [ ] ?if ;
M: propagate-key-gesture send-queued-gesture
[ gesture>> ] [ world>> world-focus ] bi
[ handle-gesture ] with each-parent drop ;
: propagate-key-gesture ( gesture world -- )
\ propagate-key-gesture queue-gesture ;
TUPLE: user-input string world ;
M: user-input send-queued-gesture
[ string>> ] [ gadget>> ] bi
[ string>> ] [ world>> world-focus ] bi
[ user-input* ] with each-parent drop ;
: user-input ( string gadget -- )
: user-input ( string world -- )
'[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
@ -261,9 +273,6 @@ SYMBOL: drag-timer
scroll-direction set-global
T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
: world-focus ( world -- gadget )
dup focus>> [ world-focus ] [ ] ?if ;
: send-action ( world gesture -- )
swap world-focus propagate-gesture ;

2
basis/ui/ui.factor
View File

@ -143,7 +143,7 @@ SYMBOL: ui-hook
graft-queue [ notify ] slurp-deque ;
: send-queued-gestures ( -- )
gesture-queue [ send-queued-gesture ] slurp-deque ;
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
[

4
basis/ui/windows/windows.factor
View File

@ -183,7 +183,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: send-key-gesture ( sym action? quot hWnd -- )
[ [ key-modifiers ] 3dip call ] dip
window-focus propagate-gesture ; inline
window propagate-key-gesture ; inline
: send-key-down ( sym action? hWnd -- )
[ [ <key-down> ] ] dip send-key-gesture ;
@ -215,7 +215,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
ctrl? alt? xor [
wParam 1string
[ f hWnd send-key-down ]
[ hWnd window-focus user-input ] bi
[ hWnd window user-input ] bi
] unless
] unless ;

7
basis/ui/x11/x11.factor
View File

@ -86,8 +86,7 @@ M: world configure-event
M: world key-down-event
[ key-down-event>gesture ] keep
world-focus
[ propagate-gesture drop ]
[ propagate-key-gesture drop ]
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
3bi ;
@ -95,7 +94,7 @@ M: world key-down-event
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
[ key-up-event>gesture ] dip world-focus propagate-gesture ;
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ]
@ -141,7 +140,7 @@ M: world focus-out-event
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
world-focus user-input ;
user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }

4
basis/unix/process/process.factor
View File

@ -74,7 +74,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
HEX: 7f bitand ; inline
: WIFEXITED ( status -- ? )
WTERMSIG zero? ; inline
WTERMSIG 0 = ; inline
: WEXITSTATUS ( status -- value )
HEX: ff00 bitand -8 shift ; inline
@ -86,7 +86,7 @@ FUNCTION: int setpriority ( int which, int who, int prio ) ;
HEX: 80 ; inline
: WCOREDUMP ( status -- ? )
WCOREFLAG bitand zero? not ; inline
WCOREFLAG bitand 0 = not ; inline
: WIFSTOPPED ( status -- ? )
HEX: ff bitand HEX: 7f = ; inline

6
core/sequences/sequences.factor
View File

@ -343,7 +343,7 @@ PRIVATE>
[ (each) ] dip collect ; inline
: 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' )
[ [ min-length ] 2keep ] dip
@ -538,12 +538,12 @@ M: sequence <=>
: sequence-hashcode-step ( oldhash newpart -- newhash )
>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
] keep fixnum-bitxor ; inline
: 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 ;

14
extra/flatland/flatland.factor
View File

@ -2,6 +2,7 @@
USING: accessors arrays fry kernel math math.vectors sequences
math.intervals
multi-methods
combinators.short-circuit
combinators.cleave.enhanced
multi-method-syntax ;
@ -218,3 +219,16 @@ USING: locals combinators ;
cond
2array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: within? ( a b -- ? )
METHOD: within? ( <pos> <rectangle> -- ? )
{
[ left to-the-right-of? ]
[ right to-the-left-of? ]
[ bottom above? ]
[ top below? ]
}
2&& ;

133
extra/pong/pong.factor
View File

@ -15,6 +15,13 @@ USING: kernel accessors locals math math.intervals math.order
IN: pong
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431
!
! Which was based on this Nodebox version: http://billmill.org/pong.html
! by Bill Mill.
!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: clamp-to-interval ( x interval -- x )
@ -95,28 +102,37 @@ METHOD: draw ( <ball> -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ;
USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided
! by multi-methods
TUPLE: <pong> < gadget draw closed ;
TUPLE: <pong> < gadget paused field ball player computer ;
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
M: <pong> draw-gadget* ( <pong> -- ) draw>> call ;
M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
: pong ( -- gadget )
<pong> new-gadget
T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } clone >>field
T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } clone >>ball
T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } clone >>player
T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ;
M: <pong> pref-dim* ( <pong> -- dim ) drop { 400 400 } ;
M: <pong> ungraft* ( <pong> -- ) t >>paused drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <pong> draw-gadget* ( PONG -- )
PONG computer>> draw
PONG player>> draw
PONG ball>> draw ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-draw-closure ( -- closure )
:: iterate-system ( GADGET -- )
! Establish some bindings
[let | PLAY-FIELD [ T{ <play-field> { pos { 0 0 } } { dim { 400 400 } } } ]
BALL [ T{ <ball> { pos { 50 50 } } { vel { 3 4 } } } ]
PLAYER [ T{ <paddle> { pos { 200 396 } } { dim { 75 4 } } } ]
COMPUTER [ T{ <computer> { pos { 200 0 } } { dim { 75 4 } } } ] |
! Define some internal words in terms of those bindings ...
[let | FIELD [ GADGET field>> ]
BALL [ GADGET ball>> ]
PLAYER [ GADGET player>> ]
COMPUTER [ GADGET computer>> ] |
[wlet | align-player-with-mouse [ ( -- )
PLAYER PLAY-FIELD align-paddle-with-mouse ]
PLAYER FIELD align-paddle-with-mouse ]
move-ball [ ( -- ) BALL 1 move-for ]
@ -127,69 +143,52 @@ M: <pong> ungraft* ( <pong> -- ) t >>closed drop ;
BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ]
bounce-off-wall? [ ( -- ? )
BALL PLAY-FIELD in-between-horizontally? not ] |
BALL FIELD in-between-horizontally? not ]
! Note, we're returning a quotation.
! The quotation closes over the bindings established by the 'let'.
! Thus the name of the word 'make-draw-closure'.
! This closure is intended to be placed in the 'draw' slot of a
! <pong> gadget.
stop-game [ ( -- ) t GADGET (>>paused) ] |
BALL FIELD in-bounds?
[
BALL PLAY-FIELD in-bounds?
[
align-player-with-mouse
move-ball
! computer reaction
BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
align-player-with-mouse
! check if ball bounced off something
player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
move-ball
! draw the objects
COMPUTER draw
PLAYER draw
BALL draw
]
when
! computer reaction
] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround.
! The stack effects in the wlet expression throw
! off the effect for the whole word, so we reset
! it to the correct one here.
BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when
BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
! check if ball bounced off something
player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when
computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when
bounce-off-wall? [ BALL reverse-horizontal-velocity ] when
]
[ stop-game ]
if
] ] ( gadget -- ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: pong-loop-step ( PONG -- ? )
PONG closed>>
[ f ]
[ PONG relayout-1 25 milliseconds sleep t ]
if ;
:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
:: start-pong-thread ( GADGET -- )
f GADGET (>>paused)
[
[
GADGET paused>>
[ f ]
[ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ]
if
]
loop
]
in-thread ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: play-pong ( -- )
: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ;
<pong> new-gadget
make-draw-closure >>draw
dup "PONG" open-window
start-pong-thread ;
: pong-main ( -- ) [ pong-window ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: play-pong-main ( -- ) [ play-pong ] with-ui ;
MAIN: play-pong-main
MAIN: pong-window