New walker

core/continuations/continuations-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private
 continuations.private parser vectors arrays namespaces
-threads assocs words quotations ;
+assocs words quotations ;
 IN: continuations
 
 ARTICLE: "errors-restartable" "Restartable errors"
@@ -44,11 +44,7 @@ ARTICLE: "continuations.private" "Continuation implementation details"
 { $subsection namestack }
 { $subsection set-namestack }
 { $subsection catchstack }
-{ $subsection set-catchstack }
+{ $subsection set-catchstack } ;
-"The continuations implementation has hooks for single-steppers:"
-{ $subsection walker-hook }
-{ $subsection set-walker-hook }
-{ $subsection (continue-with) } ;
 
 ARTICLE: "continuations" "Continuations"
 "At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
@@ -110,10 +106,6 @@ HELP: callcc1
 { $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
 { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
 
-HELP: (continue-with)
-{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
-{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
-
 HELP: continue
 { $values { "continuation" continuation } }
 { $description "Resumes a continuation reified by " { $link callcc0 } "." } ;

core/hashtables/hashtables.factor

@@ -16,7 +16,6 @@ IN: hashtables
     2 fixnum+fast over wrap ; inline
 
 : (key@) ( key keys i -- array n ? )
-    #! cond form expanded by hand for better interpreter speed
     3dup swap array-nth dup ((tombstone)) eq? [
         2drop probe (key@)
     ] [
@@ -40,7 +39,6 @@ IN: hashtables
     swap <hash-array> over set-hash-array init-hash ;
 
 : (new-key@) ( key keys i -- keys n empty? )
-    #! cond form expanded by hand for better interpreter speed
     3dup swap array-nth dup ((empty)) eq? [
         2drop rot drop t
     ] [

core/prettyprint/prettyprint.factor

@@ -94,43 +94,34 @@ SYMBOL: ->
 { { foreground { 1 1 1 1 } } { background { 0 0 0 1 } } }
 "word-style" set-word-prop
 
-! This code is ugly and could probably be simplified
+: remove-step-into ( word -- )
-! : remove-step-into
+    building get dup empty? [ drop ] [ nip pop wrapped ] if , ;
-!     building get dup empty? [
+
-!         drop \ (step-into) ,
+: (remove-breakpoints) ( quot -- newquot )
-!     ] [
+    [
-!         pop dup wrapper? [
+        [
-!             wrapped dup \ break eq?
+            {
-!             [ drop ] [ , ] if
+                { [ dup word? not ] [ , ] }
-!         ] [
+                { [ dup "break?" word-prop ] [ drop ] }
-!             ,
+                { [ dup "step-into?" word-prop ] [ remove-step-into ] }
-!         ] if
+                { [ t ] [ , ] }
-!     ] if ;
+            } cond
-! 
+        ] each
-! : (remove-breakpoints) ( quot -- newquot )
+    ] [ ] make ;
-!     [
+
-!         [
+: remove-breakpoints ( quot pos -- quot' )
-!             dup {
+    over quotation? [
-!                 { break [ drop ] }
+        1+ cut [ (remove-breakpoints) ] 2apply
-!                 { (step-into) [ remove-step-into ] }
+        [ -> ] swap 3append
-!                 [ , ]
+    ] [
-!             } case
+        drop
-!         ] each
+    ] if ;
-!     ] [ ] make ;
-! 
-! : remove-breakpoints ( quot pos -- quot' )
-!     over quotation? [
-!         1+ cut [ (remove-breakpoints) ] 2apply
-!         [ -> ] swap 3append
-!     ] [
-!         drop
-!     ] if ;
 
 PRIVATE>
 
 : callstack. ( callstack -- )
     callstack>array 2 <groups> [
-        ! remove-breakpoints
+        remove-breakpoints
         2 nesting-limit [ . ] with-variable
     ] assoc-each ;
 

core/threads/threads-docs.factor

@@ -62,7 +62,6 @@ HELP: thread
         { { $link thread-name } " - the name passed to " { $link spawn } "." }
         { { $link thread-quot } " - the initial quotation passed to " { $link spawn } "." }
         { { $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.factor

@@ -10,8 +10,8 @@ boxes ;
 SYMBOL: initial-thread
 
 TUPLE: thread
-name quot error-handler
+name quot error-handler exit-handler
-id registered?
+id
 continuation state
 mailbox variables ;
 
@@ -37,37 +37,37 @@ threads global [ H{ } assoc-like ] change-at
 
 : thread ( id -- thread ) threads at ;
 
-<PRIVATE
+: thread-registered? ( thread -- ? )
+    thread-id threads key? ;
 
 : check-unregistered
     dup thread-registered?
-    [ "Registering a thread twice" throw ] when ;
+    [ "Thread already stopped" throw ] when ;
 
 : check-registered
     dup thread-registered?
-    [ "Unregistering a thread twice" throw ] unless ;
+    [ "Thread is not running" throw ] unless ;
+
+<PRIVATE
 
 : register-thread ( thread -- )
-    check-unregistered
+    check-unregistered dup thread-id threads set-at ;
-    t over set-thread-registered?
-    dup thread-id threads set-at ;
 
 : unregister-thread ( thread -- )
-    check-registered
+    check-registered thread-id threads delete-at ;
-    f over set-thread-registered?
-    thread-id threads delete-at ;
 
 : set-self ( thread -- ) 40 setenv ; inline
 
 PRIVATE>
 
 : <thread> ( quot name error-handler -- thread )
-    \ thread counter <box> {
+    \ thread counter <box> [ ] {
         set-thread-quot
         set-thread-name
         set-thread-error-handler
         set-thread-id
         set-thread-continuation
+        set-thread-exit-handler
     } \ thread construct ;
 
 : run-queue 42 getenv ;
@@ -95,16 +95,12 @@ PRIVATE>
     drop ;
 
 : next ( -- )
-    walker-hook [
+    wake-up
-        continue
+    run-queue pop-back
-    ] [
+    dup array? [ first2 ] [ f swap ] if dup set-self
-        wake-up
+    f over set-thread-state
-        run-queue pop-back
+    thread-continuation box>
-        dup array? [ first2 ] [ f swap ] if dup set-self
+    continue-with ;
-        f over set-thread-state
-        thread-continuation box>
-        continue-with
-    ] if* ;
 
 PRIVATE>
 
@@ -116,7 +112,8 @@ PRIVATE>
     } cond ;
 
 : stop ( -- )
-    self unregister-thread next ;
+    self dup thread-exit-handler call
+    unregister-thread next ;
 
 : suspend ( quot state -- obj )
     [
@@ -145,20 +142,20 @@ PRIVATE>
         ] 1 (throw)
     ] "spawn" suspend 2drop ;
 
+: default-thread-error-handler ( error thread -- )
+    global [
+        "Error in thread " write
+        dup thread-id pprint
+        " (" write
+        dup thread-name pprint ")" print
+        "spawned to call " write
+        thread-quot short.
+        nl
+        print-error flush
+    ] bind ;
+
 : spawn ( quot name -- thread )
-    [
+    [ default-thread-error-handler ] <thread> [ (spawn) ] keep ;
-        global [
-            "Error in thread " write
-            dup thread-id pprint
-            " (" write
-            dup thread-name pprint ")" print
-            "spawned to call " write
-            thread-quot short.
-            nl
-            print-error flush
-        ] bind
-    ] <thread>
-    [ (spawn) ] keep ;
 
 : spawn-server ( quot name -- thread )
     >r [ [ ] [ ] while ] curry r> spawn ;
@@ -177,7 +174,6 @@ PRIVATE>
     initial-thread global
     [ drop f "Initial" [ die ] <thread> ] cache
     <box> over set-thread-continuation
-    f over set-thread-registered?
     dup register-thread
     set-self ;
 

extra/bootstrap/ui/tools/tools.factor

@@ -7,4 +7,6 @@ USING: kernel vocabs vocabs.loader sequences system ;
     "ui.cocoa" vocab [
         "ui.cocoa.tools" require
     ] when
+
+    "ui.tools.walker" require
 ] when

extra/concurrency/exchangers/exchangers.factor

@@ -17,5 +17,5 @@ TUPLE: exchanger thread object ;
         >r exchanger-thread box> resume-with r>
     ] [
         [ exchanger-object >box ] keep
-        [ exchanger-thread >box ] curry "Exchange wait" suspend
+        [ exchanger-thread >box ] curry "exchange" suspend
     ] if ;

extra/concurrency/messaging/messaging.factor

@@ -84,7 +84,7 @@ GENERIC: send ( message process -- )
     ] ?if ;
 
 M: thread send ( message thread -- )
-    mailbox-of mailbox-put ;
+    check-registered mailbox-of mailbox-put ;
 
 : ?linked dup linked? [ rethrow ] when ;
 
@@ -97,7 +97,7 @@ M: thread send ( message thread -- )
     mailbox mailbox-get? ?linked ; inline
 
 : rethrow-linked ( error process supervisor -- )
-    pick thread-death? [ 3drop ] [ >r <linked> r> send ] if ;
+    >r <linked> r> send ;
 
 : spawn-linked-to ( quot name mailbox -- thread )
     [ >r <linked> r> mailbox-put ] curry <thread>

extra/help/handbook/handbook.factor

@@ -66,8 +66,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
     { "All other types of objects are pushed on the data stack." }
 }
 "If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
-$nl
+{ $see-also "compiler" } ;
-"There are various ways of implementing these evaluation semantics. See " { $link "compiler" } " and " { $link "meta-interpreter" } "." ;
 
 ARTICLE: "dataflow" "Data and control flow"
 { $subsection "evaluator" }
@@ -196,7 +195,6 @@ ARTICLE: "tools" "Developer tools"
 "Debugging tools:"
 { $subsection "tools.annotations" }
 { $subsection "tools.test" }
-{ $subsection "meta-interpreter" }
 "Performance tools:"
 { $subsection "tools.memory" }
 { $subsection "profiling" }

extra/tar/tar.factor

@@ -1,7 +1,7 @@
 USING: combinators io io.files io.streams.duplex
 io.streams.string kernel math math.parser continuations
 namespaces pack prettyprint sequences strings system
-hexdump tools.interpreter ;
+hexdump ;
 IN: tar
 
 : zero-checksum 256 ;

extra/tools/annotations/annotations.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words parser io inspector quotations sequences
 prettyprint continuations effects definitions compiler.units
-namespaces assocs ;
+namespaces assocs tools.walker ;
 IN: tools.annotations
 
 : reset ( word -- )
@@ -61,7 +61,7 @@ IN: tools.annotations
     dupd [ (watch-vars) ] 2curry annotate ;
 
 : breakpoint ( word -- )
-    [ \ break add* ] annotate ;
+    [ add-breakpoint ] annotate ;
 
 : breakpoint-if ( word quot -- )
     [ [ [ break ] when ] rot 3append ] curry annotate ;

extra/tools/threads/threads.factor

@@ -7,13 +7,13 @@ io io.styles sequences assocs namespaces sorting boxes ;
 : thread. ( thread -- )
     dup thread-id pprint-cell
     dup thread-name pprint-cell
-    thread-state [ "Waiting for " swap append ] [ "Running" ] if*
+    thread-state "running" or
     [ write ] with-cell ;
 
 : threads. ( -- )
     standard-table-style [
         [
-            { "ID" "Name" "State" }
+            { "ID" "Name" "Waiting on" }
             [ [ write ] with-cell ] each
         ] with-row
 

extra/tools/walker/debug/debug.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises models tools.walker kernel
-sequences concurrency.messaging locals ;
+sequences concurrency.messaging locals continuations
+threads ;
 IN: tools.walker.debug
 
 :: test-walker | quot |
@@ -9,7 +10,7 @@ IN: tools.walker.debug
            s [ f <model> ]
            c [ f <model> ] |
         [ s c start-walker-thread p fulfill break ]
-        quot compose
+        quot compose "Walker test" spawn drop
 
         step-into-all
         p ?promise

extra/tools/walker/summary.txt

@@ -1 +1 @@
-Meta-circular interpreter and single-stepper support
+Single-stepper for walking through code

extra/tools/walker/walker.factor

@@ -6,29 +6,56 @@ concurrency.messaging quotations kernel.private words
 sequences.private assocs models ;
 IN: tools.walker
 
-SYMBOL: walker-hook
+SYMBOL: new-walker-hook
+SYMBOL: show-walker-hook
 
 ! Thread local
 SYMBOL: walker-thread
+SYMBOL: walking-thread
 
 : get-walker-thread ( -- thread )
     walker-thread tget [
-        walker-hook get [ "No walker hook" throw ] or call
+        dup show-walker-hook get call
+    ] [
+        new-walker-hook get call
         walker-thread tget
-    ] unless* ;
+    ] if* ;
 
 : break ( -- )
-    callstack [
+    continuation callstack over set-continuation-call
-        over set-continuation-call
 
-        get-walker-thread send-synchronous {
+    get-walker-thread send-synchronous {
-            { [ dup continuation? ] [ (continue) ] }
+        { [ dup continuation? ] [ (continue) ] }
-            { [ dup quotation? ] [ call ] }
+        { [ dup quotation? ] [ call ] }
-            { [ dup not ] [ "Single stepping abandoned" throw ] }
+        { [ dup not ] [ "Single stepping abandoned" throw ] }
-        } cond
+    } cond ;
-    ] curry callcc0 ;
 
-: walk ( quot -- ) \ break add* call ;
+\ break t "break?" set-word-prop
+
+: add-breakpoint ( quot -- quot' )
+    dup [ break ] head? [ \ break add* ] unless ;
+
+: walk ( quot -- ) add-breakpoint call ;
+
+: (step-into-if) ? walk ;
+
+: (step-into-dispatch) nth walk ;
+
+: (step-into-execute) ( word -- )
+    dup "step-into" word-prop [
+        call
+    ] [
+        dup primitive? [
+            execute break
+        ] [
+            word-def walk
+        ] if
+    ] ?if ;
+
+\ (step-into-execute) t "step-into?" set-word-prop
+
+: (step-into-continuation)
+    continuation callstack over set-continuation-call break ;
 
 ! Messages sent to walker thread
 SYMBOL: step
@@ -49,10 +76,12 @@ SYMBOL: walker-history
 SYMBOL: +running+
 SYMBOL: +suspended+
 SYMBOL: +stopped+
+SYMBOL: +detached+
 
 : change-frame ( continuation quot -- continuation' )
     #! Applies quot to innermost call frame of the
     #! continuation.
+    >r clone r>
     over continuation-call clone
     [
         dup innermost-frame-scan 1+
@@ -74,32 +103,6 @@ SYMBOL: +stopped+
 : step-out-msg ( continuation -- continuation' )
     [ nip \ break add ] change-frame ;
 
-GENERIC: (step-into) ( obj -- )
-
-M: wrapper (step-into) wrapped break ;
-M: object (step-into) break ;
-M: callable (step-into) \ break add* break ;
-
-: (step-into-if) ? walk ;
-
-: (step-into-dispatch) nth walk ;
-
-: (step-into-execute) ( word -- )
-    dup "step-into" word-prop [
-        call
-    ] [
-        dup primitive? [
-            execute break
-        ] [
-            word-def walk
-        ] if
-    ] ?if ;
-
-: (step-into-continuation)
-    continuation callstack over set-continuation-call break ;
-
-M: word (step-into) (step-into-execute) ;
-
 {
     { call [ walk ] }
     { (throw) [ drop walk ] }
@@ -124,7 +127,12 @@ M: word (step-into) (step-into-execute) ;
 : step-into-msg ( continuation -- continuation' )
     [
         swap cut [
-            swap % unclip literalize , \ (step-into) , %
+            swap % unclip {
+                { [ dup \ break eq? ] [ , ] }
+                { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+                { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+                { [ t ] [ , \ break , ] }
+            } cond %
         ] [ ] make
     ] change-frame ;
 
@@ -134,44 +142,55 @@ M: word (step-into) (step-into-execute) ;
 : set-status ( symbol -- )
     walker-status tget set-model ;
 
-: detach-msg ( -- f )
+: unassociate-thread ( -- )
-    +stopped+ set-status ;
+    walker-thread walking-thread tget thread-variables delete-at
+    [ ] walking-thread tget set-thread-exit-handler ;
 
-: keep-running ( continuation -- continuation )
+: detach-msg ( -- )
-    +running+ set-status
+    +detached+ set-status
-    dup continuation? [ dup walker-history tget push ] when ;
+    unassociate-thread ;
+
+: keep-running ( -- )
+    +running+ set-status ;
 
 : walker-stopped ( -- )
     +stopped+ set-status
-    [
+    [ status +stopped+ eq? ] [
-        {
-            { detach [ detach-msg ] }
-            [ drop f ]
-        } case
-    ] handle-synchronous
-    walker-stopped ;
-
-: step-into-all-loop ( -- )
-    +running+ set-status
-    [ status +stopped+ eq? not ] [
         [
             {
                 { detach [ detach-msg ] }
-                { step [ f ] }
+                [ drop ]
-                { step-out [ f ] }
+            } case f
-                { step-into [ f ] }
-                { step-all [ f ] }
-                { step-into-all [ f ] }
-                { step-back [ f ] }
-                { f [ walker-stopped ] }
-                [ step-into-msg ]
-            } case
         ] handle-synchronous
     ] [ ] while ;
 
+: step-into-all-loop ( -- )
+    +running+ set-status
+    [ status +running+ eq? ] [
+        [
+            {
+                { detach [ detach-msg ] }
+                { step [ ] }
+                { step-out [ ] }
+                { step-into [ ] }
+                { step-all [ ] }
+                { step-into-all [ ] }
+                { step-back [ ] }
+                { f [ walker-stopped ] }
+                [ step-into-msg ]
+            } case f
+        ] handle-synchronous
+    ] [ ] while ;
+
+: step-back-msg ( continuation -- continuation' )
+    walker-history tget dup pop*
+    empty? [ drop walker-history tget pop ] unless ;
+
 : walker-suspended ( continuation -- continuation' )
     +suspended+ set-status
     [ status +suspended+ eq? ] [
+        dup walker-history tget push
+        dup walker-continuation tget set-model
         [
             {
                 ! These are sent by the walker tool. We reply
@@ -189,25 +208,26 @@ M: word (step-into) (step-into-execute) ;
                 ! Pass quotation to debugged thread
                 { call-in [ nip keep-running ] }
                 ! Pass previous continuation to debugged thread
-                { step-back [ drop walker-history tget pop f ] }
+                { step-back [ step-back-msg ] }
-            } case
+            } case f
         ] handle-synchronous
     ] [ ] while ;
 
 : walker-loop ( -- )
     +running+ set-status
-    [ status +stopped+ eq? not ] [
+    [ status +detached+ eq? not ] [
         [
             {
-                { detach [ detach-msg ] }
+                { detach [ detach-msg f ] }
                 ! ignore these commands while the thread is
                 ! running
                 { step [ f ] }
                 { step-out [ f ] }
                 { step-into [ f ] }
                 { step-all [ f ] }
-                { step-into-all [ step-into-all-loop ] }
+                { step-into-all [ step-into-all-loop f ] }
                 { step-back [ f ] }
+                { abandon [ f ] }
                 { f [ walker-stopped f ] }
                 ! thread hit a breakpoint and sent us the
                 ! continuation, so we modify it and send it
@@ -218,15 +238,17 @@ M: word (step-into) (step-into-execute) ;
     ] [ ] while ;
 
 : associate-thread ( walker -- )
-    dup walker-thread tset
+    walker-thread tset
-    [ f swap send ] curry self set-thread-exit-handler ;
+    [ f walker-thread tget send-synchronous drop ]
+    self set-thread-exit-handler ;
 
 : start-walker-thread ( status continuation -- thread' )
-    [
+    self [
+        walking-thread tset
         walker-continuation tset
         walker-status tset
         V{ } clone walker-history tset
         walker-loop
-    ] 2curry
+    ] 3curry
     "Walker on " self thread-name append spawn
     [ associate-thread ] keep ;

extra/ui/backend/backend.factor

@@ -15,7 +15,7 @@ HOOK: (open-window) ui-backend ( world -- )
 
 HOOK: (close-window) ui-backend ( handle -- )
 
-HOOK: raise-window ui-backend ( world -- )
+HOOK: raise-window* ui-backend ( world -- )
 
 HOOK: select-gl-context ui-backend ( handle -- )
 

extra/ui/cocoa/cocoa.factor

@@ -85,7 +85,7 @@ M: cocoa-ui-backend close-window ( gadget -- )
         world-handle second f -> performClose:
     ] when* ;
 
-M: cocoa-ui-backend raise-window ( world -- )
+M: cocoa-ui-backend raise-window* ( world -- )
     world-handle [
         second dup f -> orderFront: -> makeKeyWindow
         NSApp 1 -> activateIgnoringOtherApps:

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

@@ -13,11 +13,6 @@ HELP: set-title
 { $description "Sets the title bar of the native window containing the world." }
 { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
 
-HELP: raise-window
-{ $values { "world" world } }
-{ $description "Makes the native window containing the given world the front-most window." }
-{ $notes "To raise the window containing a specific gadget, use " { $link find-world } " to find the world containing the gadget first." } ;
-
 HELP: select-gl-context
 { $values { "handle" "a backend-specific handle" } }
 { $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;

extra/ui/tools/operations/operations.factor

@@ -5,7 +5,7 @@ ui.tools.interactor ui.tools.listener ui.tools.profiler
 ui.tools.search ui.tools.traceback ui.tools.workspace generic
 help.topics inference inspector io.files io.styles kernel
 namespaces parser prettyprint quotations tools.annotations
-editors tools.profiler tools.test tools.time tools.interpreter
+editors tools.profiler tools.test tools.time tools.walker
 ui.commands ui.gadgets.editors ui.gestures ui.operations
 ui.tools.deploy vocabs vocabs.loader words sequences
 tools.browser classes compiler.units ;

extra/ui/tools/tools-docs.factor

@@ -1,5 +1,5 @@
 USING: editors help.markup help.syntax inspector io listener
-parser prettyprint tools.profiler tools.interpreter ui.commands
+parser prettyprint tools.profiler tools.walker ui.commands
 ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
 ui.gadgets.slots ui.operations ui.tools.browser
 ui.tools.interactor ui.tools.listener ui.tools.operations
@@ -54,14 +54,6 @@ ARTICLE: "ui-browser" "UI browser"
 { $command-map browser-gadget "toolbar" }
 "Browsers are instances of " { $link browser-gadget } "." ;
 
-ARTICLE: "ui-walker" "UI walker"
-"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
-$nl
-"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
-{ $command-map walker "toolbar" }
-{ $command-map walker "other" }
-"Walkers are instances of " { $link walker } "." ;
-
 ARTICLE: "ui-profiler" "UI profiler" 
 "The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
 $nl
@@ -134,9 +126,9 @@ $nl
 { $subsection "ui-listener" }
 { $subsection "ui-browser" }
 { $subsection "ui-inspector" }
-{ $subsection "ui-walker" }
 { $subsection "ui-profiler" }
 "Additional tools:"
+{ $subsection "ui-walker" }
 { $subsection "ui.tools.deploy" }
 "Platform-specific features:"
 { $subsection "ui-cocoa" } ;

extra/ui/tools/tools.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs debugger ui.tools.workspace
 ui.tools.operations ui.tools.browser ui.tools.inspector
-ui.tools.listener ui.tools.profiler ui.tools.walker
+ui.tools.listener ui.tools.profiler
 ui.tools.operations inspector io kernel math models namespaces
 prettyprint quotations sequences ui ui.commands ui.gadgets
 ui.gadgets.books ui.gadgets.buttons
@@ -23,7 +23,6 @@ IN: ui.tools
         <stack-display> ,
         <browser-gadget> ,
         <inspector-gadget> ,
-        <walker> ,
         <profiler-gadget> ,
     ] { } make g gadget-model <book> ;
 
@@ -62,15 +61,12 @@ M: workspace model-changed
 
 : com-inspector inspector-gadget select-tool ;
 
-: com-walker walker select-tool ;
-
 : com-profiler profiler-gadget select-tool ;
 
 workspace "tool-switching" f {
     { T{ key-down f { A+ } "1" } com-listener }
     { T{ key-down f { A+ } "2" } com-browser }
     { T{ key-down f { A+ } "3" } com-inspector }
-    { T{ key-down f { A+ } "4" } com-walker }
     { T{ key-down f { A+ } "5" } com-profiler }
 } define-command-map
 

extra/ui/tools/walker/walker-docs.factor

@@ -0,0 +1,11 @@
+IN: ui.tools.walker
+USING: help.markup help.syntax ui.commands ui.operations
+tools.walker ;
+
+ARTICLE: "ui-walker" "UI walker"
+"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."
+$nl
+"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."
+{ $command-map walker-gadget "toolbar" }
+{ $command-map walker-gadget "other" }
+"Walkers are instances of " { $link walker-gadget } "." ;

extra/ui/tools/walker/walker-tests.factor

@@ -1,8 +1,8 @@
 USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
 listener tools.test ui ui.gadgets ui.gadgets.worlds
-ui.gadgets.packs vectors ui.tools tools.interpreter
+ui.gadgets.packs vectors ui.tools tools.walker
-tools.interpreter.debug tools.test.ui ;
+tools.walker.debug tools.test.ui ;
 IN: temporary
 
 \ <walker> must-infer

extra/ui/tools/walker/walker.factor

@@ -1,95 +1,92 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs ui.tools.listener ui.tools.traceback
+USING: kernel concurrency.messaging inspector ui.tools.listener
-ui.tools.workspace inspector kernel models namespaces
+ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
-prettyprint quotations sequences threads
+ui.gadgets.tracks ui.commands ui.gadgets models
-tools.interpreter ui.commands ui.gadgets ui.gadgets.labelled
+ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons
+namespaces tools.walker assocs ;
-ui.gadgets.panes prettyprint.config prettyprint.backend
-continuations ;
 IN: ui.tools.walker
 
-TUPLE: walker model interpreter history ;
+TUPLE: walker-gadget status continuation thread ;
 
-: update-stacks ( walker -- )
+: walker-command ( walker msg -- )
-    dup walker-interpreter interpreter-continuation
+    over walker-gadget-thread thread-registered?
-    swap walker-model set-model ;
+    [ swap walker-gadget-thread send-synchronous drop ]
+    [ 2drop ] if ;
 
-: with-walker ( walker quot -- )
+: com-step ( walker -- ) step walker-command ;
-    over >r >r walker-interpreter r> call r>
-    update-stacks ; inline
 
-: walker-active? ( walker -- ? )
+: com-into ( walker -- ) step-into walker-command ;
-    walker-interpreter interpreter-continuation >boolean ;
 
-: save-interpreter ( walker -- )
+: com-out ( walker -- ) step-out walker-command ;
-    dup walker-interpreter interpreter-continuation clone
-    swap walker-history push ;
 
-: walker-command ( gadget quot -- )
+: com-back ( walker -- ) step-back walker-command ;
-    over walker-active? [
-        over save-interpreter
-        with-walker
-    ] [ 2drop ] if ; inline
 
-: com-step ( walker -- ) [ step ] walker-command ;
+: com-continue ( walker -- ) step-all walker-command ;
 
-: com-into ( walker -- ) [ step-into ] walker-command ;
+: com-abandon ( walker -- ) abandon walker-command ;
-
-: com-out ( walker -- ) [ step-out ] walker-command ;
-
-: com-back ( walker -- )
-    dup walker-history
-    dup empty? [ 2drop ] [ pop swap call-tool* ] if ;
-
-: reset-walker ( walker -- )
-    <interpreter> over set-walker-interpreter
-    V{ } clone over set-walker-history
-    update-stacks ;
-
-M: walker graft* dup delegate graft* reset-walker ;
-
-: <walker> ( -- gadget )
-    f <model> f f walker construct-boa [
-        toolbar,
-        g walker-model <traceback-gadget> 1 track,
-    ] { 0 1 } build-track ;
-
-M: walker call-tool* ( continuation walker -- )
-    [ restore ] with-walker ;
 
 : com-inspect ( walker -- )
-    dup walker-active? [
+    walker-continuation model-value
-        walker-interpreter interpreter-continuation
+    [ inspect ] curry call-listener ;
-        [ inspect ] curry call-listener
-    ] [
-        drop
-    ] if ;
 
-: com-continue ( walker -- )
+M: walker-gadget ungraft*
-    #! Reset walker first, in case step-all ends up calling
+    dup delegate ungraft* detach walker-command ;
-    #! the walker again.
+
-    dup walker-active? [
+: walker-state-string ( status thread -- string )
-        dup walker-interpreter swap reset-walker step-all
+    [
-    ] [
+        "Thread: " %
+        dup thread-name %
+        " (" %
+        swap {
+            { +stopped+ "Stopped" }
+            { +suspended+ "Suspended" }
+            { +running+ "Running" }
+            { +detached+ "Detached" }
+        } at %
+        ")" %
         drop
-    ] if ;
+    ] "" make ;
+
+: <thread-status> ( model thread -- gadget )
+    [ walker-state-string ] curry <filter> <label-control> ;
+
+: <walker-gadget> ( status continuation thread -- gadget )
+    walker-gadget construct-boa [
+        toolbar,
+        g walker-gadget-status self <thread-status> f track,
+        g walker-gadget-continuation <traceback-gadget> 1 track,
+    ] { 0 1 } build-track ;
 
 : walker-help "ui-walker" help-window ;
 
 \ walker-help H{ { +nullary+ t } } define-command
 
-walker "toolbar" f {
+walker-gadget "toolbar" f {
-    { T{ key-down f { A+ } "s" } com-step }
+    { T{ key-down f f "s" } com-step }
-    { T{ key-down f { A+ } "i" } com-into }
+    { T{ key-down f f "i" } com-into }
-    { T{ key-down f { A+ } "o" } com-out }
+    { T{ key-down f f "o" } com-out }
-    { T{ key-down f { A+ } "b" } com-back }
+    { T{ key-down f f "b" } com-back }
-    { T{ key-down f { A+ } "c" } com-continue }
+    { T{ key-down f f "c" } com-continue }
+    { T{ key-down f f "a" } com-abandon }
     { T{ key-down f f "F1" } walker-help }
 } define-command-map
 
-walker "other" f {
+walker-gadget "other" f {
-    { T{ key-down f { A+ } "n" } com-inspect }
+    { T{ key-down f f "n" } com-inspect }
+    { T{ key-down f f "d" } close-window }
 } define-command-map
 
-[ walker call-tool stop ] break-hook set-global
+: walker-window ( -- )
+    f <model> f <model> 2dup start-walker-thread
+    [ <walker-gadget> ] keep thread-name open-status-window ;
+
+[ [ walker-window ] with-ui ] new-walker-hook set-global
+
+[
+    [
+        >r dup walker-gadget?
+        [ walker-gadget-thread r> eq? ]
+        [ r> 2drop f ] if
+    ] curry find-window raise-window
+] show-walker-hook set-global

extra/ui/ui-docs.factor

@@ -26,7 +26,7 @@ HELP: fullscreen?
 
 HELP: find-window
 { $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
+{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
 
 HELP: register-window
 { $values { "world" world } { "handle" "a baackend-specific handle" } }
@@ -185,6 +185,10 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
 "If the user clicks the window's close box, you must call the following word:"
 { $subsection close-window } ;
 
+HELP: raise-window
+{ $values { "gadget" gadget } }
+{ $description "Makes the native window containing the given gadget the front-most window." } ;
+
 ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
 "A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
 { $subsection "ui-layout-basics" }

extra/ui/ui.factor

@@ -131,10 +131,8 @@ SYMBOL: ui-hook
     graft-queue [ notify ] dlist-slurp ;
 
 : ui-step ( -- )
-    [ do-timers ] assert-depth
+    [ do-timers notify-queued layout-queued redraw-worlds ]
-    [ notify-queued ] assert-depth
+    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 ;
@@ -149,6 +147,9 @@ SYMBOL: ui-hook
 : fullscreen? ( gadget -- ? )
     find-world fullscreen* ;
 
+: raise-window ( gadget -- )
+    find-world raise-window* ;
+
 HOOK: close-window ui-backend ( gadget -- )
 
 M: object close-window

extra/ui/windows/windows.factor

@@ -438,7 +438,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
     win-hDC SwapBuffers win32-error=0/f ;
 
 ! Move window to front
-M: windows-ui-backend raise-window ( world -- )
+M: windows-ui-backend raise-window* ( world -- )
     world-handle [
         win-hWnd SetFocus drop
     ] when* ;

extra/ui/x11/x11.factor

@@ -235,7 +235,7 @@ M: x11-ui-backend (open-window) ( world -- )
     dup gadget-window
     world-handle x11-handle-window dup set-closable map-window ;
 
-M: x11-ui-backend raise-window ( world -- )
+M: x11-ui-backend raise-window* ( world -- )
     world-handle [
         dpy get swap x11-handle-window XRaiseWindow drop
     ] when* ;