From 8d5135682fbc10007ddf1db4fc47fc8b31c017f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 21:07:46 -0500 Subject: [PATCH 1/7] Print a message when tests fail --- basis/tools/test/test.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index d3304bbdb1..5c2bd8f4e3 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -12,6 +12,7 @@ SYMBOL: failures error-continuation get 3array ; : failure ( error what -- ) + "--> test failed!" print failures get push ; SYMBOL: this-test From 325dbf3eefb6e29faf15d0878a5f0f504d85ab6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 21:07:55 -0500 Subject: [PATCH 2/7] Fix regression --- core/classes/tuple/tuple.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8cde049524..ecff54d9bc 100644 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -138,8 +138,12 @@ ERROR: bad-superclass class ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; +: prepare-slots ( slots superclass -- slots' ) + [ make-slots ] [ class-size 2 + ] bi* finalize-slots ; + : define-tuple-slots ( class -- ) - dup "slots" word-prop define-accessors ; + dup "slots" word-prop over superclass prepare-slots + define-accessors ; : make-tuple-layout ( class -- layout ) [ ] @@ -242,7 +246,7 @@ PRIVATE> : define-tuple-class ( class superclass slots -- ) over check-superclass - make-slots over class-size 2 + finalize-slots + over prepare-slots (define-tuple-class) ; M: word (define-tuple-class) From 1df08ba8c800a12e529dd6d2ca084186b3e5ad9b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 22:05:22 -0500 Subject: [PATCH 3/7] Unit tests no longer use hard-coded ports --- basis/http/http-tests.factor | 159 +++++++++--------- .../connection/connection-tests.factor | 19 +-- basis/tools/deploy/deploy-tests.factor | 38 +++-- basis/tools/deploy/test/5/5.factor | 7 +- 4 files changed, 109 insertions(+), 114 deletions(-) diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index b3930878ff..96320b7d12 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -192,110 +192,104 @@ test-db [ init-furnace-tables ] with-db -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + ] with-scope "port" set ; [ ] [ - [ + + add-quit-action - add-quit-action - - "resource:basis/http/test" >>default - "nested" add-responder - - [ URL" redirect-loop" ] >>display - "redirect-loop" add-responder - main-responder set + "resource:basis/http/test" >>default + "nested" add-responder + + [ URL" redirect-loop" ] >>display + "redirect-loop" add-responder - test-httpd - ] with-scope + test-httpd ] unit-test +: add-port ( url -- url' ) + >url clone "port" get >>port ; + [ t ] [ "resource:basis/http/test/foo.html" ascii file-contents - "http://localhost:1237/nested/foo.html" http-get nip = + "http://localhost/nested/foo.html" add-port http-get nip = ] unit-test -[ "http://localhost:1237/redirect-loop" http-get nip ] +[ "http://localhost/redirect-loop" add-port http-get nip ] [ too-many-redirects? ] must-fail-with [ "Goodbye" ] [ - "http://localhost:1237/quit" http-get nip + "http://localhost/quit" add-port http-get nip ] unit-test ! HTTP client redirect bug [ ] [ - [ - - add-quit-action - [ "quit" ] >>display - "redirect" add-responder - main-responder set + + add-quit-action + [ "quit" ] >>display + "redirect" add-responder - test-httpd - ] with-scope + test-httpd ] unit-test [ "Goodbye" ] [ - "http://localhost:1237/redirect" http-get nip + "http://localhost/redirect" add-port http-get nip ] unit-test [ ] [ - [ "http://localhost:1237/quit" http-get 2drop ] ignore-errors + [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors ] unit-test ! Dispatcher bugs [ ] [ - [ + + + "Test" + + "" add-responder + add-quit-action - - "Test" - - "" add-responder - add-quit-action - - "" add-responder - "d" add-responder - test-db - main-responder set + "" add-responder + "d" add-responder + test-db - test-httpd - ] with-scope + test-httpd ] unit-test : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ; ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with ! This should give a 404 not an infinite redirect loop -[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with +[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test [ ] [ - [ - - [ [ "Hi" write ] "text/plain" ] >>display - "Test" - - "" add-responder - add-quit-action - test-db - main-responder set + + [ [ "Hi" write ] "text/plain" ] >>display + "Test" + + "" add-responder + add-quit-action + test-db - test-httpd - ] with-scope + test-httpd ] unit-test -[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test +[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.elements html.forms xml xml.utilities validators @@ -304,22 +298,19 @@ furnace furnace.conversations ; SYMBOL: a [ ] [ - [ - - - [ a get-global "a" set-value ] >>init - [ [ "a" render ] "text/html" ] >>display - [ { { "a" [ v-integer ] } } validate-params ] >>validate - [ "a" value a set-global URL" " ] >>submit - - - >>default - add-quit-action - test-db - main-responder set + + + [ a get-global "a" set-value ] >>init + [ [ "a" render ] "text/html" ] >>display + [ { { "a" [ v-integer ] } } validate-params ] >>validate + [ "a" value a set-global URL" " ] >>submit + + + >>default + add-quit-action + test-db - test-httpd - ] with-scope + test-httpd ] unit-test 3 a set-global @@ -327,27 +318,35 @@ SYMBOL: a : test-a string>xml "input" tag-named "value" swap at ; [ "3" ] [ - "http://localhost:1237/" http-get + "http://localhost/" add-port http-get swap dup cookies>> "cookies" set session-id-key get-cookie value>> "session-id" set test-a ] unit-test [ "4" ] [ - H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union - "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a + [ + "4" "a" set + "http://localhost" add-port "__u" set + "session-id" get session-id-key set + ] H{ } make-assoc + "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test ! Test flash scope [ "xyz" ] [ - H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union - "http://localhost:1237/" "cookies" get >>cookies http-request nip test-a + [ + "xyz" "a" set + "http://localhost" add-port "__u" set + "session-id" get session-id-key set + ] H{ } make-assoc + "http://localhost/" add-port "cookies" get >>cookies http-request nip test-a ] unit-test [ 4 ] [ a get-global ] unit-test -[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test +[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test ! Test cloning [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index a3223ed2aa..ae79290f0a 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ; init-server semaphore>> count>> ] unit-test -[ ] [ "p" set ] unit-test - [ ] [ 5 >>max-connections - 1237 >>insecure + 0 >>insecure [ "Hello world." write stop-this-server ] >>handler - "server" set + dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ ] [ - [ - "server" get start-server - t "p" get fulfill - ] in-thread -] unit-test - -[ ] [ "server" get wait-for-server ] unit-test - -[ "Hello world." ] [ "localhost" 1237 ascii drop contents ] unit-test - -[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index db4255cdb1..71e83ea29c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -1,7 +1,8 @@ IN: tools.deploy.tests USING: tools.test system io.files kernel tools.deploy.config tools.deploy.backend math sequences io.launcher arrays -namespaces continuations layouts accessors ; +namespaces continuations layouts accessors io.encodings.ascii +urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors @@ -38,7 +39,7 @@ namespaces continuations layouts accessors ; ! [ ] [ "tetris" shake-and-bake ] unit-test ! ! [ t ] [ 1500000 small-enough? ] unit-test -! + [ ] [ "bunny" shake-and-bake ] unit-test [ t ] [ 2500000 small-enough? ] unit-test @@ -71,22 +72,24 @@ M: quit-responder call-responder* : add-quot-responder ( responder -- responder ) quit-responder "quit" add-responder ; -: test-httpd ( -- ) - #! Return as soon as server is running. - - 1237 >>insecure - f >>secure - start-server* ; +: test-httpd ( responder -- ) + [ + main-responder set + + 0 >>insecure + f >>secure + dup start-server* + sockets>> first addr>> port>> + dup number>string "resource:temp/port-number" ascii set-file-contents + ] with-scope + "port" set ; [ ] [ - [ - - add-quot-responder - "resource:basis/http/test" >>default - main-responder set + + add-quot-responder + "resource:basis/http/test" >>default - test-httpd - ] with-scope + test-httpd ] unit-test [ ] [ @@ -94,7 +97,10 @@ M: quit-responder call-responder* run-temp-image ] unit-test -[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test +: add-port ( url -- url' ) + >url clone "port" get >>port ; + +[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test [ ] [ "tools.deploy.test.6" shake-and-bake diff --git a/basis/tools/deploy/test/5/5.factor b/basis/tools/deploy/test/5/5.factor index debc020d49..9118fa3ca7 100644 --- a/basis/tools/deploy/test/5/5.factor +++ b/basis/tools/deploy/test/5/5.factor @@ -1,7 +1,10 @@ IN: tools.deploy.test.5 -USING: http.client kernel ; +USING: accessors urls io.encodings.ascii io.files math.parser +http.client kernel ; : deploy-test-5 ( -- ) - "http://localhost:1237/foo.html" http-get 2drop ; + URL" http://localhost/foo.html" clone + "resource:port-number" ascii file-contents string>number >>port + http-get 2drop ; MAIN: deploy-test-5 From 76cde4e005e277be1449f11928f4073c675785b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 22:55:57 -0500 Subject: [PATCH 4/7] Fix tetris deployment --- extra/tetris/deploy.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) 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" } } From 6c985918807d8c7315bd8bd871af8748a7cc3c31 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:07:54 -0500 Subject: [PATCH 5/7] Don't hardcode port number in socket benchmark --- extra/benchmark/richards/richards.factor | 272 +++++++++++++++++++++++ extra/benchmark/sockets/sockets.factor | 26 ++- 2 files changed, 289 insertions(+), 9 deletions(-) create mode 100644 extra/benchmark/richards/richards.factor 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 + +: ( link id kind -- packet ) + packet new + swap >>kind + swap >>id + swap >>link + 0 >>a1 + BUFSIZE 0 >>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 ; + +: ( 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 ; + +: ( 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 } ; + +: ( 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 } ; + +: ( 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 to: task-tab + f to: tracing + 0 to: hold-count + 0 to: qpkt-count ; + +: start ( -- ) + I_IDLE 1 10000 drop + + I_WORK 1000 + f 0 K_WORK 0 K_WORK + drop + + I_HANDLERA 2000 + f I_DEVA K_DEV + I_DEVA K_DEV + I_DEVA K_DEV + drop + + I_HANDLERB 3000 + f I_DEVB K_DEV + I_DEVB K_DEV + I_DEVB K_DEV + drop + + I_DEVA 4000 f drop + I_DEVB 4000 f 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 ; +: server-addr ( -- addr ) + "127.0.0.1" port-promise get ?promise ; : 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 dup "server" set [ - server-loop - ] with-disposal + "127.0.0.1" 0 ascii + [ 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 [ + port-promise set dup 2 * counter set [ simple-server ] "Simple server" spawn drop yield yield From a8d1ec34f8c227d8af953b1f7df04afd846f5aa6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:28:02 -0500 Subject: [PATCH 6/7] Fix an UI bug and remove some pick usages --- basis/ui/tools/listener/listener-tests.factor | 4 +++- basis/ui/tools/listener/listener.factor | 11 ++++++----- basis/ui/tools/tools.factor | 8 ++++---- 3 files changed, 13 insertions(+), 10 deletions(-) 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 + +[ ] [ \ + 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 From 655b483ff1e5be0bec1fb7bb41a1bfc33fbe64d8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 20 Oct 2008 23:29:38 -0500 Subject: [PATCH 7/7] Move unfinished benchmark to unfinished --- {extra => unfinished}/benchmark/richards/richards.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {extra => unfinished}/benchmark/richards/richards.factor (100%) diff --git a/extra/benchmark/richards/richards.factor b/unfinished/benchmark/richards/richards.factor similarity index 100% rename from extra/benchmark/richards/richards.factor rename to unfinished/benchmark/richards/richards.factor