diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor
index e86b52c664..616226a9c5 100644
--- a/basis/ui/tools/listener/listener-tests.factor
+++ b/basis/ui/tools/listener/listener-tests.factor
@@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic threads accessors listener ;
+threads arrays generic threads accessors listener math ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
@@ -51,3 +51,5 @@ IN: ui.tools.listener.tests
[ ] [ "listener" get com-end ] unit-test
] with-grafted-gadget
+
+[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 6fc6fa4f10..4c8b88d62c 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -101,8 +101,8 @@ M: engine-word word-completion-string
"engine-generic" word-prop word-completion-string ;
: use-if-necessary ( word seq -- )
- over vocabulary>> [
- 2dup assoc-stack pick = [ 2drop ] [
+ over vocabulary>> over and [
+ 2dup [ assoc-stack ] keep = [ 2drop ] [
>r vocabulary>> vocab-words r> push
] if
] [ 2drop ] if ;
@@ -114,9 +114,10 @@ M: engine-word word-completion-string
2bi ;
: quot-action ( interactor -- lines )
- dup control-value
- dup "\n" join pick add-interactor-history
- swap select-all ;
+ [ control-value ] keep
+ [ [ "\n" join ] dip add-interactor-history ]
+ [ select-all ]
+ 2bi ;
TUPLE: stack-display < track ;
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index f4205061cd..aed4b9d675 100644
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@@ -40,11 +40,11 @@ IN: ui.tools
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
- 1/5 1 pick set-nth
- 4/5 2 rot set-nth
+ 1/5 over set-second
+ 4/5 swap set-third
] [
- 2/3 1 pick set-nth
- 1/3 2 rot set-nth
+ 2/3 over set-second
+ 1/3 swap set-third
] if relayout ;
M: workspace model-changed
diff --git a/extra/benchmark/richards/richards.factor b/extra/benchmark/richards/richards.factor
new file mode 100644
index 0000000000..894948e44f
--- /dev/null
+++ b/extra/benchmark/richards/richards.factor
@@ -0,0 +1,272 @@
+! Based on http://research.sun.com/people/mario/java_benchmarking/
+! Ported by Factor by Slava Pestov
+!
+! Based on original version written in BCPL by Dr Martin Richards
+! in 1981 at Cambridge University Computer Laboratory, England
+! Java version: Copyright (C) 1995 Sun Microsystems, Inc.
+! by Jonathan Gibbons.
+! Outer loop added 8/7/96 by Alex Jacoby
+USING: values kernel accessors math math.bitwise sequences
+arrays combinators fry locals ;
+IN: benchmark.richards
+
+! Packets
+TUPLE: packet link id kind a1 a2 ;
+
+: BUFSIZE 4 ; inline
+
+: <packet> ( link id kind -- packet )
+ packet new
+ swap >>kind
+ swap >>id
+ swap >>link
+ 0 >>a1
+ BUFSIZE 0 <array> >>a2 ;
+
+: last-packet ( packet -- last )
+ dup link>> [ last-packet ] [ ] ?if ;
+
+: append-to ( packet list -- packet )
+ [ f >>link ] dip
+ [ tuck last-packet >>link drop ] when* ;
+
+! Tasks
+: I_IDLE 1 ; inline
+: I_WORK 2 ; inline
+: I_HANDLERA 3 ; inline
+: I_HANDLERB 4 ; inline
+: I_DEVA 5 ; inline
+: I_DEVB 6 ; inline
+
+! Packet types
+: K_DEV 1000 ; inline
+: K_WORK 1001 ; inline
+
+: PKTBIT 1 ; inline
+: WAITBIT 2 ; inline
+: HOLDBIT 4 ; inline
+
+: S_RUN 0 ; inline
+: S_RUNPKT { PKTBIT } flags ; inline
+: S_WAIT { WAITBIT } flags ; inline
+: S_WAITPKT { WAITBIT PKTBIT } flags ; inline
+: S_HOLD { HOLDBIT } flags ; inline
+: S_HOLDPKT { HOLDBIT PKTBIT } flags ; inline
+: S_HOLDWAIT { HOLDBIT WAITBIT } flags ; inline
+: S_HOLDWAITPKT { HOLDBIT WAITBIT PKTBIT } flags ; inline
+
+: task-tab-size 10 ; inline
+
+VALUE: task-tab
+VALUE: task-list
+VALUE: tracing
+VALUE: hold-count
+VALUE: qpkt-count
+
+TUPLE: task link id pri wkq state ;
+
+: new-task ( id pri wkq state class -- task )
+ new
+ swap >>state
+ swap >>wkq
+ swap >>pri
+ swap >>id
+ task-list >>link
+ dup to: task-list
+ dup dup id>> task-tab set-nth ; inline
+
+GENERIC: fn ( packet task -- task )
+
+: state-on ( task flag -- task )
+ '[ _ bitor ] change-state ; inline
+
+: state-off ( task flag -- task )
+ '[ _ bitnot bitand ] change-state ; inline
+
+: wait-task ( task -- task )
+ WAITBIT state-on ;
+
+: hold ( task -- task )
+ hold-count 1+ to: hold-count
+ HOLDBIT state-on
+ link>> ;
+
+: highest-priority ( t1 t2 -- t1/t2 )
+ [ [ pri>> ] bi@ > ] most ;
+
+: find-tcb ( i -- task )
+ task-tab nth [ "Bad task" throw ] unless* ;
+
+: release ( task i -- task )
+ find-tcb HOLDBIT state-off highest-priority ;
+
+:: qpkt ( task pkt -- task )
+ [let | t [ pkt id>> find-tcb ] |
+ t [
+ qpkt-count 1+ to: qpkt-count
+ f pkt (>>link)
+ task id>> pkt (>>id)
+ t wkq>> [
+ pkt t wkq>> append-to t (>>wkq)
+ task
+ ] [
+ pkt t (>>wkq)
+ t PKTBIT state-on drop
+ t task highest-priority
+ ] if
+ ] [ task ] if
+ ] ;
+
+: schedule-waitpkt ( task -- task pkt )
+ dup wkq>>
+ 2dup link>> >>wkq drop
+ 2dup S_RUNPKT S_RUN ? >>state drop ; inline
+
+: schedule-run ( task pkt -- task )
+ swap fn ; inline
+
+: schedule-wait ( task -- task )
+ link>> ; inline
+
+: (schedule) ( task -- )
+ [
+ dup state>> {
+ { S_WAITPKT [ schedule-waitpkt schedule-run (schedule) ] }
+ { S_RUN [ f schedule-run (schedule) ] }
+ { S_RUNPKT [ f schedule-run (schedule) ] }
+ { S_WAIT [ schedule-wait (schedule) ] }
+ { S_HOLD [ schedule-wait (schedule) ] }
+ { S_HOLDPKT [ schedule-wait (schedule) ] }
+ { S_HOLDWAIT [ schedule-wait (schedule) ] }
+ { S_HOLDWAITPKT [ schedule-wait (schedule) ] }
+ [ 2drop ]
+ } case
+ ] when* ;
+
+: schedule ( -- )
+ task-list (schedule) ;
+
+! Device task
+TUPLE: device-task < task v1 ;
+
+: <device-task> ( id pri wkq -- task )
+ dup S_WAITPKT S_WAIT ? device-task new-task ;
+
+M:: device-task fn ( pkt task -- task )
+ pkt [
+ task dup v1>>
+ [ wait-task ]
+ [ [ f ] change-v1 swap qpkt ] if
+ ] [ pkt task (>>v1) task hold ] if ;
+
+TUPLE: handler-task < task workpkts devpkts ;
+
+: <handler-task> ( id pri wkq -- task )
+ dup S_WAITPKT S_WAIT ? handler-task new-task ;
+
+M:: handler-task fn ( pkt task -- task )
+ pkt [
+ task over kind>> K_WORK =
+ [ [ append-to ] change-workpkts ]
+ [ [ append-to ] change-devpkts ]
+ if drop
+ ] when*
+
+ task workpkts>> [
+ [let* | devpkt [ task devpkts>> ]
+ workpkt [ task workpkts>> ]
+ count [ workpkt a1>> ] |
+ count BUFSIZE > [
+ workpkt link>> task (>>workpkts)
+ task workpkt qpkt
+ ] [
+ devpkt [
+ devpkt link>> task (>>devpkts)
+ count workpkt a2>> nth devpkt (>>a1)
+ count 1+ workpkt (>>a1)
+ task devpkt qpkt
+ ] [
+ task wait-task
+ ] if
+ ] if
+ ]
+ ] [ task wait-task ] if ;
+
+! Idle task
+TUPLE: idle-task < task { v1 fixnum } { v2 fixnum } ;
+
+: <idle-task> ( i a1 a2 -- task )
+ [ 0 f S_RUN idle-task new-task ] 2dip
+ [ >>v1 ] [ >>v2 ] bi* ;
+
+M: idle-task fn ( pkt task -- task )
+ nip
+ [ 1- ] change-v2
+ dup v2>> 0 = [ hold ] [
+ dup v1>> 1 bitand 0 = [
+ [ -1 shift ] change-v1
+ I_DEVA release
+ ] [
+ [ -1 shift HEX: d008 bitor ] change-v1
+ I_DEVB release
+ ] if
+ ] if ;
+
+! Work task
+TUPLE: work-task < task { handler fixnum } { n fixnum } ;
+
+: <work-task> ( id pri w -- work-task )
+ dup S_WAITPKT S_WAIT ? work-task new-task
+ I_HANDLERA >>handler
+ 0 >>n ;
+
+M:: work-task fn ( pkt task -- task )
+ pkt [
+ task [ I_HANDLERA = I_HANDLERB I_HANDLERA ? ] change-handler drop
+ task handler>> pkt (>>id)
+ 0 pkt (>>a1)
+ BUFSIZE [| i |
+ task [ 1+ ] change-n drop
+ task n>> 26 > [ 1 task (>>n) ] when
+ task n>> 1 - CHAR: A + i pkt a2>> set-nth
+ ] each
+ task pkt qpkt
+ ] [ task wait-task ] if ;
+
+! Main
+: init ( -- )
+ task-tab-size f <array> to: task-tab
+ f to: tracing
+ 0 to: hold-count
+ 0 to: qpkt-count ;
+
+: start ( -- )
+ I_IDLE 1 10000 <idle-task> drop
+
+ I_WORK 1000
+ f 0 K_WORK <packet> 0 K_WORK <packet>
+ <work-task> drop
+
+ I_HANDLERA 2000
+ f I_DEVA K_DEV <packet>
+ I_DEVA K_DEV <packet>
+ I_DEVA K_DEV <packet>
+ <handler-task> drop
+
+ I_HANDLERB 3000
+ f I_DEVB K_DEV <packet>
+ I_DEVB K_DEV <packet>
+ I_DEVB K_DEV <packet>
+ <handler-task> drop
+
+ I_DEVA 4000 f <device-task> drop
+ I_DEVB 4000 f <device-task> drop ;
+
+: check ( -- )
+ qpkt-count 23246 assert=
+ hold-count 9297 assert= ;
+
+: run ( -- )
+ init
+ start
+ schedule check ;
diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor
index 68e3a625a7..20c905156b 100755
--- a/extra/benchmark/sockets/sockets.factor
+++ b/extra/benchmark/sockets/sockets.factor
@@ -1,20 +1,25 @@
-USING: io.sockets io kernel math threads io.encodings.ascii
-io.streams.duplex debugger tools.time prettyprint
-concurrency.count-downs namespaces arrays continuations
-destructors ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math threads io io.sockets
+io.encodings.ascii io.streams.duplex debugger tools.time
+prettyprint concurrency.count-downs concurrency.promises
+namespaces arrays continuations destructors ;
IN: benchmark.sockets
SYMBOL: counter
+SYMBOL: port-promise
+SYMBOL: server
: number-of-requests 1000 ;
-: server-addr ( -- addr ) "127.0.0.1" 7777 <inet4> ;
+: server-addr ( -- addr )
+ "127.0.0.1" port-promise get ?promise <inet4> ;
: server-loop ( server -- )
dup accept drop [
[
read1 CHAR: x = [
- "server" get dispose
+ server get dispose
] [
number-of-requests
[ read1 write1 flush ] times
@@ -25,9 +30,11 @@ SYMBOL: counter
: simple-server ( -- )
[
- server-addr ascii <server> dup "server" set [
- server-loop
- ] with-disposal
+ "127.0.0.1" 0 <inet4> ascii <server>
+ [ server set ]
+ [ addr>> port>> port-promise get fulfill ]
+ [ [ server-loop ] with-disposal ]
+ tri
] ignore-errors ;
: simple-client ( -- )
@@ -47,6 +54,7 @@ SYMBOL: counter
: clients ( n -- )
dup pprint " clients: " write [
+ <promise> port-promise set
dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop
yield yield
diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor
index 57a5eda494..a21e592cc8 100755
--- a/extra/tetris/deploy.factor
+++ b/extra/tetris/deploy.factor
@@ -1,12 +1,15 @@
USING: tools.deploy.config ;
-V{
+H{
{ deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
{ deploy-compiler? t }
- { deploy-math? t }
+ { deploy-threads? t }
{ deploy-word-props? f }
- { deploy-c-types? f }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
+ { deploy-random? t }
+ { deploy-io 2 }
+ { deploy-math? t }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
{ deploy-name "Tetris" }
}