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

basis/alien/c-types/c-types-tests.factor

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

basis/alien/syntax/syntax-docs.factor

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

basis/alien/syntax/syntax.factor

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

basis/compiler/tests/alien.factor

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

basis/core-foundation/fsevents/fsevents.factor

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

basis/environment/unix/unix.factor

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

basis/http/client/client.factor

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

basis/io/launcher/launcher-docs.factor

@@ -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 } }
+{ $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"
 "Words which launch processes can take either a command line string, a sequence of command line arguments, or a " { $link process } "."

basis/io/launcher/launcher.factor

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

basis/io/unix/backend/backend.factor

@@ -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
+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
 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 -- )
+: multiplexer-error ( n -- n )
-    0 < [
+    dup 0 < [
         err_no [ EAGAIN = ] [ EINTR = ] bi or
-        [ (io-error) ] unless
+        [ drop 0 ] [ (io-error) ] if
     ] when ;
 
 : ?flag ( n mask symbol -- n )

basis/io/unix/bsd/bsd.factor

@@ -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> 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 -- )
 !     swap [ "Recursive kqueue monitors not supported" throw ] when

basis/io/unix/epoll/epoll.factor

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

basis/io/unix/files/freebsd/freebsd.factor

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

basis/io/unix/files/linux/linux.factor

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

basis/io/unix/files/netbsd/netbsd.factor

@@ -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
+io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8 ;
+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 ]

basis/io/unix/files/openbsd/openbsd.factor

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

basis/io/unix/kqueue/kqueue.factor

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

basis/io/unix/launcher/launcher-tests.factor

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

basis/io/unix/launcher/launcher.factor

@@ -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 [
+        find-process dup
-            swap *int WEXITSTATUS notify-exit f
+        [ swap *int code>status notify-exit f ] [ 2drop f ] if
-        ] [
-            2drop f
-        ] if
     ] if ;

basis/io/unix/macosx/macosx.factor

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

basis/io/unix/select/select.factor

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

basis/tools/disassembler/disassembler-docs.factor

@@ -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." }
+{ $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"
-"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"

basis/tools/disassembler/disassembler.factor

@@ -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
+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-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" ;
 
-: 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

basis/tools/disassembler/gdb/gdb.factor

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

basis/tools/disassembler/gdb/tags.txt

@@ -0,0 +1 @@
+unportable

basis/tools/disassembler/udis/tags.txt

@@ -0,0 +1 @@
+unportable

basis/tools/disassembler/udis/udis.factor

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

basis/ui/cocoa/views/views.factor

@@ -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 [
+            [ drop window-focus gadget-selection ] dip over
-                r> set-pasteboard-string 1
+            [ set-pasteboard-string 1 ] [ 2drop 0 ] if
-            ] [
+        ] [ 3drop 0 ] if
-                r> 2drop 0
-            ] if
-        ] [
-            3drop 0
-        ] if
     ]
 }
 
 { "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
     [
         pasteboard-string dup [
-            [ drop window-focus ] dip swap user-input 1
+            [ drop window ] dip swap user-input 1
-        ] [
+        ] [ 3drop 0 ] if
-            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" }

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -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." } ;
 

basis/ui/gestures/gestures-docs.factor

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

basis/ui/gestures/gestures.factor

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

basis/ui/ui.factor

@@ -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 ( -- )
     [

basis/ui/windows/windows.factor

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

basis/ui/x11/x11.factor

@@ -86,8 +86,7 @@ M: world configure-event
 
 M: world key-down-event
     [ key-down-event>gesture ] keep
-    world-focus
+    [ propagate-key-gesture drop ]
-    [ propagate-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" }

basis/unix/process/process.factor

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

core/sequences/sequences.factor

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

extra/flatland/flatland.factor

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

extra/pong/pong.factor

@@ -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 } ;
+: pong ( -- gadget )
-M: <pong> draw-gadget* ( <pong> --     ) draw>> call      ;
+  <pong> new-gadget
-M: <pong> ungraft*     ( <pong> --     ) t >>closed drop  ;
+  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  ;
     
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: make-draw-closure ( -- closure )
+M:: <pong> draw-gadget* ( PONG -- )
 
-  ! Establish some bindings
+  PONG computer>> draw
+  PONG player>>   draw
+  PONG ball>>     draw ;
 
-  [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 } } } ]
+:: iterate-system ( GADGET -- )
-         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.
+            stop-game [ ( -- ) t GADGET (>>paused) ] |
-      ! 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.
 
+      BALL FIELD in-bounds?
       [
 
-        BALL PLAY-FIELD in-bounds?
+        align-player-with-mouse
-          [
-            align-player-with-mouse
 
-            move-ball
+        move-ball
 
-            ! computer reaction
+        ! computer reaction
 
-            BALL COMPUTER to-the-left-of?  [ COMPUTER computer-move-left  ] when
+        BALL COMPUTER to-the-left-of?  [ COMPUTER computer-move-left  ] when
-            BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
+        BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when
 
-            ! check if ball bounced off something
+        ! check if ball bounced off something
               
-            player-blocked-ball?   [ BALL PLAYER   bounce-off-paddle  ] when
+        player-blocked-ball?   [ BALL PLAYER   bounce-off-paddle  ] when
-            computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle  ] when
+        computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle  ] when
-            bounce-off-wall?       [ BALL reverse-horizontal-velocity ] when
+        bounce-off-wall?       [ BALL reverse-horizontal-velocity ] when
+      ]
+      [ stop-game ]
+      if
 
-            ! draw the objects
+  ] ] ( gadget -- ) ;
-              
-            COMPUTER draw
-            PLAYER   draw
-            BALL     draw
-  
-          ]
-        when
-
-      ] ] ] ( -- 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.
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-:: pong-loop-step ( PONG -- ? )
+:: start-pong-thread ( GADGET -- )
-  PONG closed>>
+  f GADGET (>>paused)
-    [ f ]
+  [
-    [ PONG relayout-1 25 milliseconds sleep t ]
+    [
-  if ;
+      GADGET paused>>
-
+      [ f ]
-:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ;
+      [ 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
+: pong-main ( -- ) [ pong-window ] with-ui ;
-    make-draw-closure >>draw
-  dup "PONG" open-window
 
-  start-pong-thread ;
+MAIN: pong-window
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: play-pong-main ( -- ) [ play-pong ] with-ui ;
-
-MAIN: play-pong-main