Clean up interpreter and walker

extra/tools/interpreter/debug/debug.factor

@@ -1,18 +1,31 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.interpreter namespaces kernel arrays continuations
+USING: tools.interpreter kernel arrays continuations threads
-threads sequences ;
+sequences namespaces ;
 IN: tools.interpreter.debug
 
-: run-interpreter ( -- )
+: run-interpreter ( interpreter -- )
-    interpreter get [ step-into run-interpreter ] when ;
+    dup interpreter-continuation [
+        dup step-into run-interpreter
+    ] [
+        drop
+    ] if ;
 
-: init-interpreter ( quot -- )
+: quot>cont ( quot -- cont )
     [
-        "out" set
+        swap [
-        [ f swap 2array restore "out" get continue ] callcc0
+            continue-with
-    ] swap [ datastack "datastack" set stop ]
+        ] curry callcc0 call stop
-    3append callcc0 ;
+    ] curry callcc1 ;
+
+: init-interpreter ( quot interpreter -- )
+    >r
+    [ datastack "datastack" set ] compose quot>cont
+    f swap 2array
+    r> restore ;
 
 : test-interpreter ( quot -- )
-    init-interpreter run-interpreter "datastack" get ;
+    <interpreter>
+    [ init-interpreter ] keep
+    run-interpreter
+    "datastack" get ;

extra/tools/interpreter/interpreter-docs.factor

@@ -2,7 +2,13 @@ USING: help.markup help.syntax kernel generic
 math hashtables quotations classes continuations ;
 IN: tools.interpreter
 
-ARTICLE: "meta-interp-step" "Single-stepping words"
+ARTICLE: "meta-interpreter" "Meta-circular interpreter"
+"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
+$nl
+"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
+$nl
+"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
+$nl
 "Breakpoints can be inserted in user code:"
 { $subsection break }
 "Breakpoints invoke a hook:"
@@ -13,40 +19,16 @@ ARTICLE: "meta-interp-step" "Single-stepping words"
 { $subsection step-out }
 { $subsection step-all } ;
 
-ARTICLE: "meta-interp-travel" "Backwards time travel"
-"Backwards time travel is implemented by capturing the continuation after every step. Since this consumes additional memory, it must be explicitly enabled by storing an empty vector into a variable:"
-{ $subsection history }
-"If this variable holds a vector, the interpreter state is automatically saved after every step. It can be saved at other points manually:"
-{ $subsection save-interpreter }
-"Or restore the most recently saved state:"
-{ $subsection step-back } ;
-
-ARTICLE: "meta-interpreter" "Meta-circular interpreter"
-"The meta-circular interpreter is used to implement the walker tool in the UI. If you are simply interested in single stepping through a piece of code, use the " { $link "ui-walker" } "."
-$nl
-"On the other hand, if you want to implement a similar tool yourself, then you can use the words described in this section."
-$nl
-"Meta-circular interpreter words are found in the " { $vocab-link "tools.interpreter" } " vocabulary."
-$nl
-"The current interpreter state is stored in the " { $link interpreter } " variable."
-{ $subsection "meta-interp-step" }
-{ $subsection "meta-interp-travel" } ;
-
 ABOUT: "meta-interpreter"
 
 HELP: interpreter
-{ $var-description "Variable holding a " { $link continuation } " instance for the single-stepper." } ;
+{ $class-description "An interpreter instance." } ;
 
 HELP: break
 { $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
 
-HELP: history
-{ $var-description "A sequence of continuations, captured at every stage of single-stepping. Used by " { $link step-back } " to implement backwards time travel." } ;
-
-HELP: save-interpreter
-{ $description "Snapshots the single stepper state and saves it in " { $link history } "." } ;
-
 HELP: step
+{ $values { "interpreter" interpreter } }
 { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
     { $list
         { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@@ -56,6 +38,7 @@ HELP: step
 } ;
 
 HELP: step-into
+{ $values { "interpreter" interpreter } }
 { $description "Evaluates the object in the single stepper using Factor evaluation semantics:"
     { $list
         { "If the object is a " { $link wrapper } ", then the wrapped object is pushed on the single stepper's data stack" }
@@ -66,10 +49,9 @@ HELP: step-into
 } ;
 
 HELP: step-out
+{ $values { "interpreter" interpreter } }
 { $description "Evaluates the remainder of the current quotation in the single stepper." } ;
 
-HELP: step-back
-{ $description "Steps back to the most recently saved snapshot of the single stepper continuation in " { $link history } "." } ;
-
 HELP: step-all
+{ $values { "interpreter" interpreter } }
 { $description "Executes the remainder of the single stepper's continuation. This effectively ends single stepping unless the continuation invokes " { $link break } " at a later point in time." } ;

extra/tools/interpreter/interpreter-tests.factor

@@ -105,54 +105,6 @@ IN: temporary
     [ [ { 1 2 3 } . ] string-out ] test-interpreter
 ] unit-test
 
-: meta-catch interpreter get continuation-catch ;
+[ { } ] [
-
+    [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope
-! Step back test
+] unit-test
-! [
-!     init-interpreter
-!     V{ } clone meta-history set
-! 
-!     V{ f } clone
-!     V{ } clone
-!     V{ [ 1 2 3 ] 0 3 } clone
-!     V{ } clone
-!     V{ } clone
-!     f <continuation>
-!     meta-catch push
-! 
-!     [ ] [ [ 2 2 + throw ] (meta-call) ] unit-test
-! 
-!     [ ] [ step ] unit-test
-! 
-!     [ ] [ step ] unit-test
-!     
-!     [ { 2 2 } ] [ meta-d ] unit-test
-! 
-!     [ ] [ step ] unit-test
-!     
-!     [ { 4 } ] [ meta-d ] unit-test
-!     [ 3 ] [ callframe-scan get ] unit-test
-!     
-!     [ ] [ step-back ] unit-test
-!     [ 2 ] [ callframe-scan get ] unit-test
-!     
-!     [ { 2 2 } ] [ meta-d ] unit-test
-!     
-!     [ ] [ step ] unit-test
-!     
-!     [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
-! 
-!     [ ] [ step ] unit-test
-!     
-!     [ [ 1 2 3 ] ] [ callframe get ] unit-test
-!     [ ] [ step-back ] unit-test
-!     
-!     [ { 4 } ] [ meta-d ] unit-test
-!     
-!     [ [ 1 2 3 ] ] [ meta-catch peek continuation-call first ] unit-test
-! 
-!     [ ] [ step ] unit-test
-!     
-!     [ [ 1 2 3 ] ] [ callframe get ] unit-test
-! 
-! ] with-scope

extra/tools/interpreter/interpreter.factor

@@ -6,7 +6,9 @@ kernel.private math namespaces namespaces.private prettyprint
 quotations sequences splitting strings threads vectors words ;
 IN: tools.interpreter
 
-SYMBOL: interpreter
+TUPLE: interpreter continuation ;
+
+: <interpreter> interpreter construct-empty ;
 
 SYMBOL: break-hook
 
@@ -15,22 +17,25 @@ SYMBOL: break-hook
     over set-continuation-call
     walker-hook [ continue-with ] [ break-hook get call ] if* ;
 
-: with-interpreter-datastack ( quot -- )
+GENERIC# restore 1 ( obj interpreter -- )
-    interpreter get continuation-data
-    swap with-datastack
-    interpreter get set-continuation-data ; inline
-
-GENERIC: restore ( obj -- )
-
-M: continuation restore
-    clone interpreter set ;
-
-M: pair restore
-    first2 clone interpreter set
-    [ nip f ] curry with-interpreter-datastack ;
 
 M: f restore
-    drop interpreter off ;
+    set-interpreter-continuation ;
+
+M: continuation restore
+    >r clone r> set-interpreter-continuation ;
+
+: with-interpreter-datastack ( quot interpreter -- )
+    interpreter-continuation [
+        continuation-data
+        swap with-datastack
+    ] keep set-continuation-data ; inline
+
+M: pair restore
+    >r first2 r> [ restore ] keep
+    >r [ nip f ] curry r> with-interpreter-datastack ;
+
+<PRIVATE
 
 : (step-into-call) \ break add* call ;
 
@@ -71,19 +76,6 @@ M: f restore
     "step-into" set-word-prop
 ] each
 
-! Time travel
-SYMBOL: history
-
-: save-interpreter ( -- )
-    history get [ interpreter get clone swap push ] when* ;
-
-: restore-interpreter ( interp -- )
-    clone interpreter set ;
-
-: step-back ( -- )
-    history get dup empty?
-    [ drop ] [ pop restore-interpreter ] if ;
-
 : (continue) ( continuation -- )
     >continuation<
     set-catchstack
@@ -93,26 +85,34 @@ SYMBOL: history
     set-callstack ;
 
 ! Stepping
-: step-all ( -- )
+: change-innermost-frame ( quot interpreter -- )
-    [ interpreter get (continue) ] in-thread ;
+    interpreter-continuation [
+        continuation-call clone
+        [
+            dup innermost-frame-scan 1+
+            swap innermost-frame-quot
+            rot call
+        ] keep
+        [ set-innermost-frame-quot ] keep
+    ] keep set-continuation-call ; inline
 
-: change-innermost-frame ( quot -- )
+: (step) ( interpreter quot -- )
-    interpreter get continuation-call clone
+    swap
+    [ change-innermost-frame ] keep
     [
-        dup innermost-frame-scan 1+
+        set-walker-hook
-        swap innermost-frame-quot
+        interpreter-continuation (continue)
-        rot call
+    ] callcc1 swap restore ;
-    ] keep
-    [ set-innermost-frame-quot ] keep
-    interpreter get set-continuation-call ; inline
 
-: (step) ( quot -- )
+GENERIC: (step-into) ( obj -- )
-    save-interpreter
-    change-innermost-frame
-    [ set-walker-hook interpreter get (continue) ] callcc1
-    restore ;
 
-: step ( n -- )
+M: word (step-into) (step-into-execute) ;
+M: wrapper (step-into) wrapped break ;
+M: object (step-into) break ;
+
+PRIVATE>
+
+: step ( interpreter -- )
     [
         2dup nth \ break = [
             nip
@@ -121,18 +121,15 @@ SYMBOL: history
         ] if
     ] (step) ;
 
-: step-out ( -- )
+: step-out ( interpreter -- )
     [ nip \ break add ] (step) ;
 
-GENERIC: (step-into) ( obj -- )
+: step-into ( interpreter -- )
-
-M: word (step-into) (step-into-execute) ;
-M: wrapper (step-into) wrapped break ;
-M: object (step-into) break ;
-
-: step-into ( -- )
     [
         cut [
             swap % unclip literalize , \ (step-into) , %
         ] [ ] make
     ] (step) ;
+
+: step-all ( interpreter -- )
+    interpreter-continuation [ (continue) ] curry in-thread ;

extra/ui/tools/tools-docs.factor

@@ -58,9 +58,9 @@ 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 "toolbar" }
-{ $command-map walker-gadget "other" }
+{ $command-map walker "other" }
-"Walkers are instances of " { $link walker-gadget } "." ;
+"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."

extra/ui/tools/tools.factor

@@ -17,7 +17,7 @@ IN: ui.tools
         <stack-display>
         <browser-gadget>
         <inspector-gadget>
-        <walker-gadget>
+        <walker>
         <profiler-gadget>
     } ;
 
@@ -65,7 +65,7 @@ M: workspace model-changed
 
 : com-inspector inspector-gadget select-tool ;
 
-: com-walker walker-gadget select-tool ;
+: com-walker walker select-tool ;
 
 : com-profiler profiler-gadget select-tool ;
 

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

@@ -4,7 +4,7 @@ listener tools.test ui ui.gadgets ui.gadgets.worlds
 ui.gadgets.packs vectors ui.tools ;
 IN: temporary
 
-[ ] [ <walker-gadget> "walker" set ] unit-test
+[ ] [ <walker "walker" set ] unit-test
 
 ! Make sure the toolbar buttons don't throw if we're
 ! not actually walking.
@@ -37,7 +37,7 @@ IN: temporary
 
     [ t ] [ "ok" get ] unit-test
 
-    [ ] [ <walker-gadget> "w" set ] unit-test
+    [ ] [ <walker> "w" set ] unit-test
     continuation "c" set
     
     [ ] [ "c" get "w" get call-tool* ] unit-test

extra/ui/tools/walker/walker.factor

@@ -8,61 +8,70 @@ ui.gestures ui.gadgets.buttons ui.gadgets.panes
 prettyprint.config prettyprint.backend ;
 IN: ui.tools.walker
 
-TUPLE: walker-gadget model ns ;
+TUPLE: walker model interpreter history ;
 
 : update-stacks ( walker -- )
-    interpreter get swap walker-gadget-model set-model ;
+    dup walker-interpreter interpreter-continuation
+    swap walker-model set-model ;
 
-: with-walker ( gadget quot -- )
+: with-walker ( walker quot -- )
-    swap dup walker-gadget-ns [ slip update-stacks ] bind ;
+    over >r >r walker-interpreter r> call r>
-    inline
+    update-stacks ; inline
 
 : walker-active? ( walker -- ? )
-    interpreter swap walker-gadget-ns key? ;
+    walker-interpreter interpreter-continuation >boolean ;
 
 : walker-command ( gadget quot -- )
     over walker-active? [ with-walker ] [ 2drop ] if ; inline
 
-: com-step [ step ] walker-command ;
+: save-interpreter ( walker -- )
-: com-into [ step-into ] walker-command ;
+    dup walker-interpreter interpreter-continuation clone
-: com-out [ step-out ] walker-command ;
+    swap walker-history push ;
-: com-back [ step-back ] walker-command ;
 
-: init-walker-models ( walker -- )
+: com-step ( walker -- )
-    f <model> over set-walker-gadget-model
+    dup save-interpreter [ step ] walker-command ;
-    H{ } clone swap set-walker-gadget-ns ;
+
+: com-into ( walker -- )
+    dup save-interpreter [ step-into ] walker-command ;
+
+: com-out ( walker -- )
+    dup save-interpreter [ step-out ] walker-command ;
+
+: com-back ( walker -- )
+    dup walker-history
+    dup empty? [ drop ] [ pop swap call-tool* ] if ;
 
 : reset-walker ( walker -- )
-    dup walker-gadget-ns clear-assoc
+    <interpreter> over set-walker-interpreter
-    [ V{ } clone history set ] with-walker ;
+    V{ } clone over set-walker-history
+    update-stacks ;
 
-: <walker-gadget> ( -- gadget )
+: <walker> ( -- gadget )
-    walker-gadget construct-empty
+    f <model> f f walker construct-boa [
-    dup init-walker-models [
         toolbar,
-        g walker-gadget-model <traceback-gadget> 1 track,
+        g walker-model <traceback-gadget> 1 track,
     ] { 0 1 } build-track
     dup reset-walker ;
 
-M: walker-gadget call-tool* ( continuation walker -- )
+M: walker call-tool* ( continuation walker -- )
     [ restore ] with-walker ;
 
 : com-inspect ( walker -- )
     dup walker-active? [
-        interpreter swap walker-gadget-ns at
+        walker-interpreter interpreter-continuation
         [ inspect ] curry call-listener
     ] [
         drop
     ] if ;
 
 : com-continue ( walker -- )
-    dup [ step-all ] walker-command reset-walker ;
+    dup walker-interpreter step-all reset-walker ;
 
 : walker-help "ui-walker" help-window ;
 
 \ walker-help H{ { +nullary+ t } } define-command
 
-walker-gadget "toolbar" f {
+walker "toolbar" f {
     { T{ key-down f { A+ } "s" } com-step }
     { T{ key-down f { A+ } "i" } com-into }
     { T{ key-down f { A+ } "o" } com-out }
@@ -71,8 +80,8 @@ walker-gadget "toolbar" f {
     { T{ key-down f f "F1" } walker-help }
 } define-command-map
 
-walker-gadget "other" f {
+walker "other" f {
     { T{ key-down f { A+ } "n" } com-inspect }
 } define-command-map
 
-[ walker-gadget call-tool stop ] break-hook set-global
+[ walker call-tool stop ] break-hook set-global