From 195acdd600587db326277b3e2e26a0959c9ad2f0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 10 Dec 2008 13:54:22 -0600
Subject: [PATCH 01/19] flatland: add 'within?'
---
extra/flatland/flatland.factor | 14 ++++++++++++++
1 file changed, 14 insertions(+)
diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor
index c98c5a6c57..72d9e50a9d 100644
--- a/extra/flatland/flatland.factor
+++ b/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&& ;
From 22fb54185685dd4786361f26353f688c085cde76 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 10 Dec 2008 13:54:41 -0600
Subject: [PATCH 02/19] pong: Un-closurify
---
extra/pong/pong.factor | 133 ++++++++++++++++++++---------------------
1 file changed, 66 insertions(+), 67 deletions(-)
diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor
index befb64a7a7..3f7626074a 100644
--- a/extra/pong/pong.factor
+++ b/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 } ;
-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
\ No newline at end of file
+MAIN: pong-window
\ No newline at end of file
From 164f8ccb678b8db3971c201b844b71f352ee919c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 10 Dec 2008 14:28:22 -0600
Subject: [PATCH 03/19] parse the fsid_t for the rest of the platforms
---
basis/io/unix/files/freebsd/freebsd.factor | 5 +++--
basis/io/unix/files/linux/linux.factor | 5 +++--
basis/io/unix/files/netbsd/netbsd.factor | 4 ++--
basis/io/unix/files/openbsd/openbsd.factor | 5 +++--
4 files changed, 11 insertions(+), 8 deletions(-)
diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor
index 3786a82b55..7fa03a97cd 100644
--- a/basis/io/unix/files/freebsd/freebsd.factor
+++ b/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 ;
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 ]
diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor
index 3e4e1c043a..cbdfbce1ce 100644
--- a/basis/io/unix/files/linux/linux.factor
+++ b/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 ;
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 ]
diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor
index 23717b41a4..702d8443e4 100644
--- a/basis/io/unix/files/netbsd/netbsd.factor
+++ b/basis/io/unix/files/netbsd/netbsd.factor
@@ -4,7 +4,7 @@ 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 ;
+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 ]
diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor
index 8c8f7c154b..51c5c4fe10 100644
--- a/basis/io/unix/files/openbsd/openbsd.factor
+++ b/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 ;
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 ]
From 2af947b08ec4f7de177ceea60021ce64eee659c0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 10 Dec 2008 14:43:56 -0600
Subject: [PATCH 04/19] fix using for recent change
---
basis/io/unix/files/freebsd/freebsd.factor | 2 +-
basis/io/unix/files/linux/linux.factor | 2 +-
basis/io/unix/files/netbsd/netbsd.factor | 2 +-
basis/io/unix/files/openbsd/openbsd.factor | 2 +-
4 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor
index 7fa03a97cd..eaf217af62 100644
--- a/basis/io/unix/files/freebsd/freebsd.factor
+++ b/basis/io/unix/files/freebsd/freebsd.factor
@@ -4,7 +4,7 @@ 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
-specialized-arrays.direct.uint ;
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor
index cbdfbce1ce..c30855c3ee 100644
--- a/basis/io/unix/files/linux/linux.factor
+++ b/basis/io/unix/files/linux/linux.factor
@@ -4,7 +4,7 @@ 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
-specialized-arrays.direct.uint ;
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.linux
TUPLE: linux-file-system-info < unix-file-system-info
diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor
index 702d8443e4..82ac3dc70d 100644
--- a/basis/io/unix/files/netbsd/netbsd.factor
+++ b/basis/io/unix/files/netbsd/netbsd.factor
@@ -3,7 +3,7 @@
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 specialized-arrays.direct.uint ;
IN: io.unix.files.netbsd
diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor
index 51c5c4fe10..e5e18b29ea 100644
--- a/basis/io/unix/files/openbsd/openbsd.factor
+++ b/basis/io/unix/files/openbsd/openbsd.factor
@@ -4,7 +4,7 @@ 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
-specialized-arrays.direct.uint ;
+specialized-arrays.direct.uint arrays ;
IN: io.unix.files.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
From 24a8cb0a958eb24fbc32770c693f9ca18460b4d4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 16:25:57 -0600
Subject: [PATCH 05/19] Remove >r/r> usage from ui.cocoa
---
basis/ui/cocoa/views/views.factor | 15 ++++-----------
1 file changed, 4 insertions(+), 11 deletions(-)
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index 128fdceeb4..f1e2f725b0 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/basis/ui/cocoa/views/views.factor
@@ -266,14 +266,9 @@ 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
]
}
@@ -281,9 +276,7 @@ CLASS: {
[
pasteboard-string dup [
[ drop window-focus ] dip swap user-input 1
- ] [
- 3drop 0
- ] if
+ ] [ 3drop 0 ] if
]
}
From 6346999f6659e08ce87e6ff6a061dbc8397a33cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 16:40:05 -0600
Subject: [PATCH 06/19] Fix race condition with gesture handling and grafting
---
basis/ui/cocoa/views/views.factor | 6 +++---
basis/ui/gestures/gestures.factor | 21 +++++++++++++++------
basis/ui/ui.factor | 2 +-
basis/ui/windows/windows.factor | 4 ++--
basis/ui/x11/x11.factor | 7 +++----
5 files changed, 24 insertions(+), 16 deletions(-)
diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor
index f1e2f725b0..7bb9679132 100644
--- a/basis/ui/cocoa/views/views.factor
+++ b/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: ;
@@ -275,14 +275,14 @@ CLASS: {
{ "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
]
}
! 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" }
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 5faaa93292..123a7620d1 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/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 ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 88f0a353b9..d9ff287014 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -140,7 +140,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 ( -- )
[
diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor
index 0510e21f17..10539df8e7 100755
--- a/basis/ui/windows/windows.factor
+++ b/basis/ui/windows/windows.factor
@@ -181,7 +181,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 ;
@@ -213,7 +213,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 ;
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index a532a13b69..b4a0427ccd 100755
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -83,8 +83,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 ;
@@ -92,7 +91,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 ]
@@ -138,7 +137,7 @@ M: world focus-out-event
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
- world-focus user-input ;
+ world user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
From e6145c71c0bb8e230f07f2f661db25476087f26e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 17:26:54 -0600
Subject: [PATCH 07/19] Change a -rot usage to 2dip
---
core/sequences/sequences.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index e364359928..7bb509cb67 100644
--- a/core/sequences/sequences.factor
+++ b/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 ;
From e57b28b6e13066b13fe6450afb408af3d3f86488 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 17:30:07 -0600
Subject: [PATCH 08/19] Check for signal exit status
---
basis/io/launcher/launcher.factor | 2 +-
basis/io/unix/launcher/launcher-tests.factor | 17 ++++++++++++++++-
basis/io/unix/launcher/launcher.factor | 12 +++++++-----
basis/unix/process/process.factor | 4 ++--
4 files changed, 26 insertions(+), 9 deletions(-)
diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index 0ed10e63c3..7bafb95376 100644
--- a/basis/io/launcher/launcher.factor
+++ b/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 -- )
diff --git a/basis/io/unix/launcher/launcher-tests.factor b/basis/io/unix/launcher/launcher-tests.factor
index 33988c273b..68ca821ed4 100644
--- a/basis/io/unix/launcher/launcher-tests.factor
+++ b/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
diff --git a/basis/io/unix/launcher/launcher.factor b/basis/io/unix/launcher/launcher.factor
index e80a372aef..729c1545d8 100644
--- a/basis/io/unix/launcher/launcher.factor
+++ b/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 [
- swap *int WEXITSTATUS notify-exit f
- ] [
- 2drop f
- ] if
+ find-process dup
+ [ swap *int code>status notify-exit f ] [ 2drop f ] if
] if ;
diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor
index 175425f948..7d5f9eb330 100644
--- a/basis/unix/process/process.factor
+++ b/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
From f86caab386b508eabd551a56f1f2e5afd6fe52ab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 17:33:29 -0600
Subject: [PATCH 09/19] Fix compile error
---
basis/ui/x11/x11.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor
index b4a0427ccd..563b98aa34 100755
--- a/basis/ui/x11/x11.factor
+++ b/basis/ui/x11/x11.factor
@@ -137,7 +137,7 @@ M: world focus-out-event
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
- world user-input ;
+ user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
From 51ee6be0475045e8fc7bd4498af3120575a131d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 19:16:49 -0600
Subject: [PATCH 10/19] Clarify wait-for-process docs
---
basis/io/launcher/launcher-docs.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor
index 45bbec20e3..3585214735 100644
--- a/basis/io/launcher/launcher-docs.factor
+++ b/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 } }
-{ $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 } "."
From cefdec0644294c91d204e628a7fa1ad2cf6a8e39 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 19:35:18 -0600
Subject: [PATCH 11/19] Use udis on x86
---
.../disassembler/disassembler-docs.factor | 6 +-
basis/tools/disassembler/disassembler.factor | 52 ++++-------
basis/tools/disassembler/gdb/gdb.factor | 36 ++++++++
basis/tools/disassembler/gdb/tags.txt | 1 +
basis/tools/disassembler/udis/udis.factor | 91 +++++++++++++++++++
5 files changed, 148 insertions(+), 38 deletions(-)
create mode 100644 basis/tools/disassembler/gdb/gdb.factor
create mode 100644 basis/tools/disassembler/gdb/tags.txt
create mode 100644 basis/tools/disassembler/udis/udis.factor
diff --git a/basis/tools/disassembler/disassembler-docs.factor b/basis/tools/disassembler/disassembler-docs.factor
index f03861a8ed..7d193d0aac 100644
--- a/basis/tools/disassembler/disassembler-docs.factor
+++ b/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." }
-{ $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"
diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor
index 76e1f0f1b8..fac340845b 100644
--- a/basis/tools/disassembler/disassembler.factor
+++ b/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
-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
diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor
new file mode 100644
index 0000000000..65d0e2f43a
--- /dev/null
+++ b/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
diff --git a/basis/tools/disassembler/gdb/tags.txt b/basis/tools/disassembler/gdb/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/tools/disassembler/gdb/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor
new file mode 100644
index 0000000000..113c07c8c3
--- /dev/null
+++ b/basis/tools/disassembler/udis/udis.factor
@@ -0,0 +1,91 @@
+! 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
+
+<< : & scan "c-library" get load-library dlsym parsed ; parsing >>
+
+<<
+"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
From 2103c591e617d4edca1dadf919cb660642afb9cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 19:36:07 -0600
Subject: [PATCH 12/19] Add unportable tag for tools.disassembler.udis
---
basis/tools/disassembler/udis/tags.txt | 1 +
1 file changed, 1 insertion(+)
create mode 100644 basis/tools/disassembler/udis/tags.txt
diff --git a/basis/tools/disassembler/udis/tags.txt b/basis/tools/disassembler/udis/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/tools/disassembler/udis/tags.txt
@@ -0,0 +1 @@
+unportable
From f020fd39ec6d53e7838a998c352885c302813afa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 19:45:42 -0600
Subject: [PATCH 13/19] Fix ui.gestures help lint
---
basis/ui/gestures/gestures-docs.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 602d3fd425..5e7bd51bec 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -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
@@ -22,8 +22,8 @@ HELP: propagate-gesture
{ $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." } ;
+{ $values { "string" string } { "world" world } }
+{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ;
HELP: motion
{ $class-description "Mouse motion gesture." }
From d327786cb9a3f5a287f7916d98dbe8c9d58d1af5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 20:10:47 -0600
Subject: [PATCH 14/19] kqueue and epoll code wasn't checking for EINTR
properly, leading to hangs
---
basis/io/unix/backend/backend.factor | 6 +++---
basis/io/unix/epoll/epoll.factor | 2 +-
basis/io/unix/kqueue/kqueue.factor | 3 +--
3 files changed, 5 insertions(+), 6 deletions(-)
diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor
index 1666d60c83..7f4e03ef09 100644
--- a/basis/io/unix/backend/backend.factor
+++ b/basis/io/unix/backend/backend.factor
@@ -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 )
diff --git a/basis/io/unix/epoll/epoll.factor b/basis/io/unix/epoll/epoll.factor
index e8d33787f3..93d0b4aa99 100644
--- a/basis/io/unix/epoll/epoll.factor
+++ b/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
diff --git a/basis/io/unix/kqueue/kqueue.factor b/basis/io/unix/kqueue/kqueue.factor
index b4e2b7af6f..be99d17572 100644
--- a/basis/io/unix/kqueue/kqueue.factor
+++ b/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
- dup multiplexer-error ;
+ ] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
[ kevent-ident swap ] [ kevent-filter ] bi {
From 537af9ed9b92ddb3ccd7c9a2ebd70b9409610ac2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 20:23:37 -0600
Subject: [PATCH 15/19] Fix docs again
---
basis/ui/gadgets/worlds/worlds-docs.factor | 4 ++++
basis/ui/gestures/gestures-docs.factor | 4 ----
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
index 35781fa568..60e4e58ed5 100644
--- a/basis/ui/gadgets/worlds/worlds-docs.factor
+++ b/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." } ;
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index 5e7bd51bec..f6495a14c3 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/basis/ui/gestures/gestures-docs.factor
@@ -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 } { "world" world } }
-{ $description "Calls " { $link user-input* } " on every parent of the world's currently-focused child." } ;
-
HELP: motion
{ $class-description "Mouse motion gesture." }
{ $examples { $code "T{ motion }" } } ;
From f849e41c7ec8e54eaed2a55ae5b182858278d81f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 20:23:37 -0600
Subject: [PATCH 16/19] Fix select MX
---
basis/io/unix/select/select.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/io/unix/select/select.factor b/basis/io/unix/select/select.factor
index 27231aee5a..a6b61001a6 100644
--- a/basis/io/unix/select/select.factor
+++ b/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 ;
From 717bceb6ff68ba3014461ca83485f8dd508ce82e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 10 Dec 2008 20:24:22 -0600
Subject: [PATCH 17/19] Use kqueue on BSD
---
basis/io/unix/bsd/bsd.factor | 11 +++--------
basis/io/unix/macosx/macosx.factor | 5 +----
2 files changed, 4 insertions(+), 12 deletions(-)
diff --git a/basis/io/unix/bsd/bsd.factor b/basis/io/unix/bsd/bsd.factor
index 50b4b610da..e1583478db 100644
--- a/basis/io/unix/bsd/bsd.factor
+++ b/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> 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
diff --git a/basis/io/unix/macosx/macosx.factor b/basis/io/unix/macosx/macosx.factor
index ef52b676fb..388d266b48 100644
--- a/basis/io/unix/macosx/macosx.factor
+++ b/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
From 0cc4dc4e0a492526183b48b1e12bfd49721f4df8 Mon Sep 17 00:00:00 2001
From: Philipp Winkler <philippwinkler@gmail.com>
Date: Wed, 10 Dec 2008 21:30:33 -0800
Subject: [PATCH 18/19] Allow post data to be send on PUT as well as POST
actions. Allow any message between 200 and 299 to mean success.
---
basis/http/client/client.factor | 10 ++++++----
1 file changed, 6 insertions(+), 4 deletions(-)
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 119fa23567..108ae5ecc4 100644
--- a/basis/http/client/client.factor
+++ b/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 ;
From c679ae025b82095defd05a2a32518209aaaecb2f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 11 Dec 2008 00:03:58 -0600
Subject: [PATCH 19/19] Rename tools.disassembler.udis:& to alien.syntax:&: and
fix it to survive image save/load
---
basis/alien/c-types/c-types-tests.factor | 2 +-
basis/alien/syntax/syntax-docs.factor | 5 +++++
basis/alien/syntax/syntax.factor | 7 ++++++-
basis/compiler/tests/alien.factor | 6 +++---
basis/core-foundation/fsevents/fsevents.factor | 2 +-
basis/environment/unix/unix.factor | 5 +++--
basis/io/unix/backend/backend.factor | 12 ++++++------
basis/tools/disassembler/udis/udis.factor | 6 ++----
8 files changed, 27 insertions(+), 18 deletions(-)
diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index f57d102452..31542b2699 100644
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/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
diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor
index 586bb97402..a3215cd8c6 100644
--- a/basis/alien/syntax/syntax-docs.factor
+++ b/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" } "." }
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index b0ba10a316..15d82884f9 100644
--- a/basis/alien/syntax/syntax.factor
+++ b/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
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 230a7bf542..1b21e40bac 100644
--- a/basis/compiler/tests/alien.factor
+++ b/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 )
diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index d4d5e88512..b3c1444043 100644
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/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
diff --git a/basis/environment/unix/unix.factor b/basis/environment/unix/unix.factor
index c2dddc25ab..7da19ee47b 100644
--- a/basis/environment/unix/unix.factor
+++ b/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 ;
diff --git a/basis/io/unix/backend/backend.factor b/basis/io/unix/backend/backend.factor
index 7f4e03ef09..954a0a61de 100644
--- a/basis/io/unix/backend/backend.factor
+++ b/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
-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
diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor
index 113c07c8c3..c5b5c80d13 100644
--- a/basis/tools/disassembler/udis/udis.factor
+++ b/basis/tools/disassembler/udis/udis.factor
@@ -5,8 +5,6 @@ alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.parser system make fry arrays ;
IN: tools.disassembler.udis
-<< : & scan "c-library" get load-library dlsym parsed ; parsing >>
-
<<
"libudis86" {
{ [ os macosx? ] [ "libudis86.0.dylib" ] }
@@ -22,8 +20,8 @@ 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_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