Implement new box data type, fix various bugs, add status parameter for suspend, threads. now prints thread state

core/boxes/boxes-docs.factor

@@ -0,0 +1,38 @@
+USING: help.markup help.syntax kernel ;
+IN: boxes
+
+HELP: box
+{ $class-description "A data type holding a single value in the " { $link box-value } " slot. The " { $link box-full? } " slot indicates if the value is set." } ;
+
+HELP: <box>
+{ $values { "box" box } }
+{ $description "Creates a new empty box." } ;
+
+HELP: >box
+{ $values { "value" object } { "box" box } }
+{ $description "Stores a value into a box." }
+{ $errors "Throws an error if the box is full." } ;
+
+HELP: box>
+{ $values { "box" box } { "value" "the value of the box" } }
+{ $description "Removes a value from a box." }
+{ $errors "Throws an error if the box is empty." } ;
+
+HELP: ?box
+{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } }
+{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
+
+ARTICLE: "boxes" "Boxes"
+"A " { $emphasis "box" } " is a container which can either be empty or hold a single value."
+{ $subsection box }
+"Creating an empty box:"
+{ $subsection <box> }
+"Testing if a box is full:"
+{ $subsection box-full? }
+"Storing a value and removing a value from a box:"
+{ $subsection >box }
+{ $subsection box> }
+"Safely removing a value:"
+{ $subsection ?box } ;
+
+ABOUT: "boxes"

core/boxes/boxes-tests.factor

@@ -0,0 +1,24 @@
+IN: temporary
+USING: boxes namespaces tools.test ;
+
+[ ] [ <box> "b" set ] unit-test
+
+[ ] [ 3 "b" get >box ] unit-test
+
+[ t ] [ "b" get box-full? ] unit-test
+
+[ 4 "b" >box ] must-fail
+
+[ 3 ] [ "b" get box> ] unit-test
+
+[ f ] [ "b" get box-full? ] unit-test
+
+[ "b" get box> ] must-fail
+
+[ f f ] [ "b" get ?box ] unit-test
+
+[ ] [ 12 "b" get >box ] unit-test
+
+[ 12 t ] [ "b" get ?box ] unit-test
+
+[ f ] [ "b" get box-full? ] unit-test

core/boxes/boxes.factor

@@ -0,0 +1,21 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: boxes
+
+TUPLE: box value full? ;
+
+: <box> ( -- box ) box construct-empty ;
+
+: >box ( value box -- )
+    dup box-full? [ "Box already has a value" throw ] when
+    t over set-box-full?
+    set-box-value ;
+
+: box> ( box -- value )
+    dup box-full? [ "Box empty" throw ] unless
+    dup box-value f pick set-box-value
+    f rot set-box-full? ;
+
+: ?box ( box -- value/f ? )
+    dup box-full? [ box> t ] [ drop f f ] if ;

core/listener/listener.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables io kernel math memory namespaces
 parser sequences strings io.styles io.streams.lines

core/parser/parser.factor

@@ -409,6 +409,7 @@ SYMBOL: interactive-vocabs
     "tools.memory"
     "tools.profiler"
     "tools.test"
+    "tools.threads"
     "tools.time"
     "vocabs"
     "vocabs.loader"

core/threads/threads-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private io
 threads.private continuations dlists init quotations strings
-assocs heaps ;
+assocs heaps boxes ;
 IN: threads
 
 ARTICLE: "threads-start/stop" "Starting and stopping threads"
@@ -61,7 +61,7 @@ HELP: thread
         { { $link thread-id } " - a unique identifier assigned to each thread." }
         { { $link thread-name } " - the name passed to " { $link spawn } "." }
         { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
-        { { $link thread-continuation } " - if the thread is waiting to run, the saved thread context. If the thread is currently running, will be " { $link f } "." }
+        { { $link thread-continuation } " - a " { $link box } "; if the thread is ready to run, the box holds the continuation, otherwise it is empty." }
         { { $link thread-registered? } " - a boolean indicating whether the thread is eligible to run or not. Spawning a thread with " { $link (spawn) } " sets this flag and " { $link stop } " clears it." }
     }
 } ;

core/threads/threads-tests.factor

@@ -12,5 +12,5 @@ yield
 [ "hey" sleep ] must-fail
 
 [ 3 ] [
-    [ 3 swap resume-with ] suspend
+    [ 3 swap resume-with ] "Test suspend" suspend
 ] unit-test

core/threads/threads.factor

@@ -4,14 +4,15 @@
 IN: threads
 USING: arrays hashtables heaps kernel kernel.private math
 namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators debugger prettyprint io init ;
+dlists assocs system combinators debugger prettyprint io init
+boxes ;
 
 SYMBOL: initial-thread
 
 TUPLE: thread
 name quot error-handler
 id registered?
-continuation
+continuation state
 mailbox variables ;
 
 : self ( -- thread ) 40 getenv ; inline
@@ -61,11 +62,12 @@ threads global [ H{ } assoc-like ] change-at
 PRIVATE>
 
 : <thread> ( quot name error-handler -- thread )
-    \ thread counter {
+    \ thread counter <box> {
         set-thread-quot
         set-thread-name
         set-thread-error-handler
         set-thread-id
+        set-thread-continuation
     } \ thread construct ;
 
 : run-queue 42 getenv ;
@@ -99,8 +101,8 @@ PRIVATE>
         wake-up
         run-queue pop-back
         dup array? [ first2 ] [ f swap ] if dup set-self
-        dup thread-continuation
-        f rot set-thread-continuation
+        f over set-thread-state
+        thread-continuation box>
         continue-with
     ] if* ;
 
@@ -116,15 +118,19 @@ PRIVATE>
 : stop ( -- )
     self unregister-thread next ;
 
-: suspend ( quot -- obj )
+: suspend ( quot state -- obj )
     [
-        >r self [ set-thread-continuation ] keep r> call next
-    ] curry callcc1 ; inline
+        self thread-continuation >box
+        self set-thread-state
+        self swap call next
+    ] callcc1 2nip ; inline
 
-: yield ( -- ) [ resume ] suspend drop ;
+: yield ( -- ) [ resume ] "yield" suspend drop ;
 
 : sleep ( ms -- )
-    >fixnum millis + [ schedule-sleep ] curry suspend drop ;
+    >fixnum millis +
+    [ schedule-sleep ] curry
+    "sleep" suspend drop ;
 
 : (spawn) ( thread -- )
     [
@@ -137,7 +143,7 @@ PRIVATE>
             >r { } set-datastack r>
             thread-quot [ call stop ] call-clear
         ] 1 (throw)
-    ] suspend 2drop ;
+    ] "spawn" suspend 2drop ;
 
 : spawn ( quot name -- thread )
     [
@@ -170,7 +176,7 @@ PRIVATE>
     <min-heap> 43 setenv
     initial-thread global
     [ drop f "Initial" [ die ] <thread> ] cache
-    f over set-thread-continuation
+    <box> over set-thread-continuation
     f over set-thread-registered?
     dup register-thread
     set-self ;

extra/concurrency/conditions/conditions.factor

@@ -9,5 +9,5 @@ IN: concurrency.conditions
 : notify-all ( dlist -- )
     [ second resume ] dlist-slurp yield ;
 
-: wait ( queue timeout -- )
-    [ 2array swap push-front ] suspend 3drop ; inline
+: wait ( queue timeout status -- )
+    >r [ 2array swap push-front ] r> suspend 3drop ; inline

extra/concurrency/exchangers/exchangers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel threads ;
+USING: kernel threads boxes ;
 IN: concurrency.exchangers
 
 ! Motivated by
@@ -9,18 +9,13 @@ IN: concurrency.exchangers
 TUPLE: exchanger thread object ;
 
 : <exchanger> ( -- exchanger )
-    f f exchanger construct-boa ;
-
-: pop-object ( exchanger -- obj )
-    dup exchanger-object f rot set-exchanger-object ;
-
-: pop-thread ( exchanger -- thread )
-    dup exchanger-thread f rot set-exchanger-thread ;
+    <box> <box> exchanger construct-boa ;
 
 : exchange ( obj exchanger -- newobj )
-    dup exchanger-thread [
-        dup pop-object >r pop-thread resume-with r>
+    dup exchanger-thread box-full? [
+        dup exchanger-object box>
+        >r exchanger-thread box> resume-with r>
     ] [
-        [ set-exchanger-object ] keep
-        [ set-exchanger-thread ] curry suspend
+        [ exchanger-object >box ] keep
+        [ exchanger-thread >box ] curry "Exchange wait" suspend
     ] if ;

extra/concurrency/locks/locks.factor

@@ -17,7 +17,7 @@ TUPLE: lock threads owner reentrant? ;
 
 : acquire-lock ( lock timeout -- )
     over lock-owner
-    [ 2dup >r lock-threads r> wait ] when drop
+    [ 2dup >r lock-threads r> "lock" wait ] when drop
     self swap set-lock-owner ;
 
 : release-lock ( lock -- )
@@ -54,7 +54,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-read-lock ( lock timeout -- )
     over rw-lock-writer
-    [ 2dup >r rw-lock-readers r> wait ] when drop
+    [ 2dup >r rw-lock-readers r> "read lock" wait ] when drop
     dup rw-lock-reader# 1+ swap set-rw-lock-reader# ;
 
 : notify-writer ( lock -- )
@@ -66,7 +66,7 @@ TUPLE: rw-lock readers writers reader# writer ;
 
 : acquire-write-lock ( lock timeout -- )
     over rw-lock-writer pick rw-lock-reader# 0 > or
-    [ 2dup >r rw-lock-writers r> wait ] when drop
+    [ 2dup >r rw-lock-writers r> "write lock" wait ] when drop
     self swap set-rw-lock-writer ;
 
 : release-write-lock ( lock -- )

extra/concurrency/messaging/messaging-tests.factor

@@ -73,18 +73,21 @@ MATCH-VARS: ?from ?to ?value ;
 SYMBOL: increment
 SYMBOL: decrement
 SYMBOL: value
+SYMBOL: exit
 
-: counter ( value -- value )
+: counter ( value -- value ? )
     receive {
-        { { increment ?value } [ ?value + ] }
-        { { decrement ?value } [ ?value - ] }
-        { { value ?from }      [ dup ?from send ] }
+        { { increment ?value } [ ?value + t ] }
+        { { decrement ?value } [ ?value - t ] }
+        { { value ?from }      [ dup ?from send t ] }
+        { exit                 [ f ] }
     } match-cond ;
 
 [ -5 ] [
-    [ 0 [ t ] [ counter ] [ ] while ] "Counter" spawn
-    { increment 10 } over send
-    { decrement 15 } over send
-    [ value , self , ] { } make swap send 
+    [ 0 [ counter ] [ ] [ ] while ] "Counter" spawn "counter" set
+    { increment 10 } "counter" get send
+    { decrement 15 } "counter" get send
+    [ value , self , ] { } make "counter" get send
     receive
+    exit "counter" get send
 ] unit-test

extra/concurrency/messaging/messaging.factor

@@ -26,12 +26,14 @@ TUPLE: mailbox threads data ;
     2over mailbox-data dlist-contains? [
         3drop
     ] [
-        2dup >r mailbox-threads r> wait block-unless-pred
+        2dup >r mailbox-threads r> "mailbox" wait
+        block-unless-pred
     ] if ; inline
 
 : block-if-empty ( mailbox timeout -- mailbox )
     over mailbox-empty? [
-        2dup >r mailbox-threads r> wait block-if-empty
+        2dup >r mailbox-threads r> "mailbox" wait
+        block-if-empty
     ] [
         drop
     ] if ;

extra/concurrency/semaphores/semaphores.factor

@@ -11,7 +11,7 @@ TUPLE: semaphore count threads ;
     <dlist> semaphore construct-boa ;
 
 : wait-to-acquire ( semaphore timeout -- )
-    >r semaphore-threads r> wait ;
+    >r semaphore-threads r> "semaphore" wait ;
 
 : acquire ( semaphore timeout -- )
     dup semaphore-count zero? [

extra/help/handbook/handbook.factor

@@ -161,6 +161,7 @@ ARTICLE: "collections" "Collections"
 { $subsection "hashtables" }
 { $subsection "alists" }
 { $heading "Other collections" }
+{ $subsection "boxes" }
 { $subsection "dlists" }
 { $subsection "heaps" }
 { $subsection "graphs" }

extra/io/launcher/launcher.factor

@@ -83,7 +83,10 @@ HOOK: run-process* io-backend ( desc -- handle )
 : wait-for-process ( process -- status )
     [
         dup process-handle
-        [ dup [ processes get at push ] curry suspend drop ] when
+        [
+            dup [ processes get at push ] curry
+            "process" suspend drop
+        ] when
         dup process-killed?
         [ "Process was killed" throw ] [ process-status ] if
     ] with-timeout ;

extra/io/monitors/monitors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend kernel continuations namespaces sequences
-assocs hashtables sorting arrays threads ;
+assocs hashtables sorting arrays threads boxes ;
 IN: io.monitors
 
 <PRIVATE
@@ -35,24 +35,21 @@ M: monitor dispose
 TUPLE: simple-monitor handle callback ;
 
 : <simple-monitor> ( handle -- simple-monitor )
-    f (monitor) {
+    f (monitor) <box> {
         set-simple-monitor-handle
         set-delegate
+        set-simple-monitor-callback
     } simple-monitor construct ;
 
 : construct-simple-monitor ( handle class -- simple-monitor )
     >r <simple-monitor> r> construct-delegate ; inline
 
 : notify-callback ( simple-monitor -- )
-    dup simple-monitor-callback
-    f rot set-simple-monitor-callback
-    [ resume ] when* ;
+    simple-monitor-callback ?box [ resume ] [ drop ] if ;
 
 M: simple-monitor fill-queue ( monitor -- )
-    dup simple-monitor-callback [
-        "Cannot wait for changes on the same file from multiple threads" throw
-    ] when
-    [ swap set-simple-monitor-callback ] suspend drop
+    [ swap simple-monitor-callback >box ]
+    "monitor" suspend drop
     check-monitor ;
 
 M: simple-monitor dispose ( monitor -- )

extra/io/server/server.factor

@@ -3,10 +3,17 @@
 USING: io io.sockets io.files logging continuations kernel
 math math.parser namespaces parser sequences strings
 prettyprint debugger quotations calendar
-threads concurrency.combinators ;
-
+threads concurrency.combinators assocs ;
 IN: io.server
 
+SYMBOL: servers
+
+<PRIVATE
+
+: spawn-vars ( quot vars name -- )
+    >r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r>
+    spawn drop ;
+
 LOG: accepted-connection NOTICE
 
 : with-client ( client quot -- )
@@ -15,23 +22,21 @@ LOG: accepted-connection NOTICE
         with-stream*
     ] curry with-disposal ; inline
 
-\ with-client NOTICE add-error-logging
+\ with-client DEBUG add-error-logging
 
 : accept-loop ( server quot -- )
     [
         >r accept r> [ with-client ] 2curry
-        "Client" spawn drop
+        { log-service servers } "Client" spawn-vars
     ] 2keep accept-loop ; inline
 
-: server-loop ( server quot -- )
+: server-loop ( addrspec quot -- )
+    >r <server> dup servers get push r>
     [ accept-loop ] curry with-disposal ; inline
 
-SYMBOL: servers
+\ server-loop NOTICE add-error-logging
 
-: spawn-server ( addrspec quot -- )
-    >r <server> dup servers get push r> server-loop ; inline
-
-\ spawn-server NOTICE add-error-logging
+PRIVATE>
 
 : local-server ( port -- seq )
     "localhost" swap t resolve-host ;
@@ -40,17 +45,18 @@ SYMBOL: servers
     f swap t resolve-host ;
 
 : with-server ( seq service quot -- )
-    [
-        V{ } clone servers set
-        [ spawn-server ] curry parallel-each
-    ] curry with-logging ; inline
+    V{ } clone [
+        servers [
+            [ server-loop ] curry with-logging
+        ] with-variable
+    ] 3curry parallel-each ; inline
 
 : stop-server ( -- )
     servers get [ dispose ] each ;
 
-: received-datagram ( addrspec -- ) drop ;
+<PRIVATE
 
-\ received-datagram NOTICE add-input-logging
+LOG: received-datagram NOTICE
 
 : datagram-loop ( quot datagram -- )
     [
@@ -63,6 +69,8 @@ SYMBOL: servers
 
 \ spawn-datagrams NOTICE add-input-logging
 
+PRIVATE>
+
 : with-datagrams ( seq service quot -- )
     [
         [ swap spawn-datagrams ] curry parallel-each

extra/io/unix/backend/backend.factor

@@ -62,7 +62,7 @@ M: mx register-io-task ( task mx -- )
     mx get-global register-io-task ;
 
 : with-port-continuation ( port quot -- port )
-    [ suspend drop ] curry with-timeout ; inline
+    [ "I/O" suspend drop ] curry with-timeout ; inline
 
 M: mx unregister-io-task ( task mx -- )
     fd/container delete-at drop ;

extra/io/windows/nt/backend/backend.factor

@@ -54,7 +54,7 @@ M: windows-nt-io add-completion ( handle -- )
         <io-callback> swap
         dup alien? [ "bad overlapped in save-callback" throw ] unless
         io-hash get-global set-at
-    ] suspend 3drop ;
+    ] "I/O" suspend 3drop ;
 
 : wait-for-overlapped ( ms -- overlapped ? )
     >r master-completion-port get-global r> ! port ms

extra/tools/threads/threads.factor

@@ -2,12 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: tools.threads
 USING: threads kernel prettyprint prettyprint.config
-io io.styles sequences assocs namespaces sorting ;
+io io.styles sequences assocs namespaces sorting boxes ;
 
 : thread. ( thread -- )
     dup thread-id pprint-cell
     dup thread-name pprint-cell
-    thread-continuation "Waiting" "Running" ? [ write ] with-cell ;
+    thread-state [ "Waiting for " swap append ] [ "Running" ] if*
+    [ write ] with-cell ;
 
 : threads. ( -- )
     standard-table-style [

extra/ui/tools/interactor/interactor.factor

@@ -6,18 +6,27 @@ math.vectors models namespaces parser prettyprint quotations
 sequences sequences.lib strings threads listener
 tuples ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions ;
+definitions boxes ;
 IN: ui.tools.interactor
 
 TUPLE: interactor
 history output
-thread quot busy?
+thread quot
 help ;
 
+: interactor-continuation ( interactor -- continuation )
+    interactor-thread box-value
+    thread-continuation box-value ;
+
+: interactor-busy? ( interactor -- ? )
+    interactor-thread box-full? not ;
+
 : interactor-use ( interactor -- seq )
-    use swap
-    interactor-thread thread-continuation continuation-name
-    assoc-stack ;
+    dup interactor-busy? [ drop f ] [
+        use swap
+        interactor-continuation continuation-name
+        assoc-stack
+    ] if ;
 
 : init-caret-help ( interactor -- )
     dup editor-caret 100 <delay> swap set-interactor-help ;
@@ -29,13 +38,13 @@ help ;
     <source-editor>
     interactor construct-editor
     tuck set-interactor-output
+    <box> over set-interactor-thread
     dup init-interactor-history
     dup init-caret-help ;
 
 M: interactor graft*
     dup delegate graft*
-    dup dup interactor-help add-connection
-    f swap set-interactor-busy? ;
+    dup interactor-help add-connection ;
 
 : word-at-loc ( loc interactor -- word )
     over [
@@ -65,17 +74,16 @@ M: interactor model-changed
     over empty? [ 2drop ] [ interactor-history push-new ] if ;
 
 : interactor-continue ( obj interactor -- )
-    t over set-interactor-busy?
-    interactor-thread resume-with ;
+    interactor-thread box> resume-with ;
 
 : clear-input ( interactor -- ) gadget-model clear-doc ;
 
 : interactor-finish ( interactor -- )
-    #! The in-thread is a kludge to make it infer. Stupid.
+    #! The spawn is a kludge to make it infer. Stupid.
     [ editor-string ] keep
     [ interactor-input. ] 2keep
     [ add-interactor-history ] keep
-    [ clear-input ] curry in-thread ;
+    [ clear-input ] curry "Clearing input" spawn drop ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [
@@ -88,12 +96,7 @@ M: interactor model-changed
     ] unless drop ;
 
 : interactor-yield ( interactor -- obj )
-    ! dup gadget-graft-state first [
-        f over set-interactor-busy?
-        [ set-interactor-thread ] curry suspend ;
-    ! ] [
-    !     drop f
-    ! ] if ;
+    [ interactor-thread >box ] curry "input" suspend ;
 
 M: interactor stream-readln
     [ interactor-yield ] keep interactor-finish ?first ;
@@ -127,7 +130,7 @@ M: interactor stream-read-partial
     [
         drop parse-lines-interactive
     ] [
-        >r f swap set-interactor-busy? drop r>
+        2nip
         dup delegate unexpected-eof? [ drop f ] when
     ] recover ;
 

extra/ui/tools/listener/listener.factor

@@ -28,11 +28,7 @@ TUPLE: listener-gadget input output stack ;
     <scroller> "Input" <labelled-gadget> f track, ;
 
 : welcome. ( -- )
-   "If this is your first time with the Factor UI," print
-   "please read " write
-   "ui-tools" ($link) " and " write
-   "ui-listener" ($link) "." print nl
-   "If you are completely new to Factor, start with the " print
+   "If this is your first time with Factor, please read the " print
    "cookbook" ($link) "." print nl ;
 
 M: listener-gadget focusable-child*
@@ -45,7 +41,8 @@ M: listener-gadget tool-scroller
     listener-gadget-output find-scroller ;
 
 : workspace-busy? ( workspace -- ? )
-    workspace-listener listener-gadget-input interactor-busy? ;
+    workspace-listener listener-gadget-input
+    interactor-busy? ;
 
 : get-listener ( -- listener )
     [ workspace-busy? not ] get-workspace* workspace-listener ;
@@ -81,8 +78,9 @@ M: listener-operation invoke-command ( target command -- )
     listener-gadget-input interactor-eof ;
 
 : clear-output ( listener -- )
-    [ listener-gadget-output [ pane-clear ] curry ] keep
-    (call-listener) ;
+    listener-gadget-output pane-clear ;
+
+\ clear-output H{ { +listener+ t } } define-command
 
 : clear-stack ( listener -- )
     [ clear ] swap (call-listener) ;
@@ -134,16 +132,16 @@ M: stack-display tool-scroller
     ] with-stream* ;
 
 : restart-listener ( listener -- )
-    [ listener-thread ] curry "Listener" spawn drop ;
+    dup com-end dup clear-output
+    [ listener-thread ] curry
+    "Listener" spawn drop ;
 
 : init-listener ( listener -- )
     f <model> swap set-listener-gadget-stack ;
 
 : <listener-gadget> ( -- gadget )
-    listener-gadget construct-empty
-    dup init-listener
-    [ listener-output, listener-input, ] { 0 1 } build-track
-    dup restart-listener ;
+    listener-gadget construct-empty dup init-listener
+    [ listener-output, listener-input, ] { 0 1 } build-track ;
 
 : listener-help "ui-listener" help-window ;
 
@@ -160,3 +158,11 @@ listener-gadget "toolbar" f {
 M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
     3dup drop swap find-workspace workspace-page handle-gesture
     [ default-gesture-handler ] [ 3drop f ] if ;
+
+M: listener-gadget graft*
+    dup delegate graft*
+    restart-listener ;
+
+M: listener-gadget ungraft*
+    dup com-end
+    delegate ungraft* ;

extra/ui/ui.factor

@@ -131,12 +131,10 @@ SYMBOL: ui-hook
     graft-queue [ notify ] dlist-slurp ;
 
 : ui-step ( -- )
-    [
-        do-timers
-        notify-queued
-        layout-queued
-        redraw-worlds
-    ] assert-depth ;
+    [ do-timers ] assert-depth
+    [ notify-queued ] assert-depth
+    [ layout-queued "a" set ] assert-depth
+    [ "a" get redraw-worlds ] assert-depth ;
 
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ui-step ;