diff --git a/extra/tools/interpreter/debug/debug.factor b/extra/tools/interpreter/debug/debug.factor index c9e40feba6..438734773f 100644 --- a/extra/tools/interpreter/debug/debug.factor +++ b/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 -threads sequences ; +USING: tools.interpreter kernel arrays continuations threads +sequences namespaces ; IN: tools.interpreter.debug -: run-interpreter ( -- ) - interpreter get [ step-into run-interpreter ] when ; +: run-interpreter ( interpreter -- ) + dup interpreter-continuation [ + dup step-into run-interpreter + ] [ + drop + ] if ; -: init-interpreter ( quot -- ) +: quot>cont ( quot -- cont ) [ - "out" set - [ f swap 2array restore "out" get continue ] callcc0 - ] swap [ datastack "datastack" set stop ] - 3append callcc0 ; + swap [ + continue-with + ] curry callcc0 call stop + ] 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 ; + + [ init-interpreter ] keep + run-interpreter + "datastack" get ; diff --git a/extra/tools/interpreter/interpreter-docs.factor b/extra/tools/interpreter/interpreter-docs.factor index 68572d1ac7..e636f7c2ce 100644 --- a/extra/tools/interpreter/interpreter-docs.factor +++ b/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." } ; diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 902953d781..d7c2ccb9bd 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/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 ; - -! Step back 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 -! 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 +[ { } ] [ + [ "a" "b" set "c" "d" set [ ] test-interpreter ] with-scope +] unit-test diff --git a/extra/tools/interpreter/interpreter.factor b/extra/tools/interpreter/interpreter.factor index 5eb1438618..c256d132cf 100644 --- a/extra/tools/interpreter/interpreter.factor +++ b/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 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 -- ) - 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 ; +GENERIC# restore 1 ( obj interpreter -- ) 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 ; + +continuation< set-catchstack @@ -93,26 +85,34 @@ SYMBOL: history set-callstack ; ! Stepping -: step-all ( -- ) - [ interpreter get (continue) ] in-thread ; +: change-innermost-frame ( quot interpreter -- ) + 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 -- ) - interpreter get continuation-call clone +: (step) ( interpreter quot -- ) + swap + [ change-innermost-frame ] keep [ - dup innermost-frame-scan 1+ - swap innermost-frame-quot - rot call - ] keep - [ set-innermost-frame-quot ] keep - interpreter get set-continuation-call ; inline + set-walker-hook + interpreter-continuation (continue) + ] callcc1 swap restore ; -: (step) ( quot -- ) - save-interpreter - change-innermost-frame - [ set-walker-hook interpreter get (continue) ] callcc1 - restore ; +GENERIC: (step-into) ( obj -- ) -: 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 -- ) - -M: word (step-into) (step-into-execute) ; -M: wrapper (step-into) wrapped break ; -M: object (step-into) break ; - -: step-into ( -- ) +: step-into ( interpreter -- ) [ cut [ swap % unclip literalize , \ (step-into) , % ] [ ] make ] (step) ; + +: step-all ( interpreter -- ) + interpreter-continuation [ (continue) ] curry in-thread ; diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index b4df493ce4..82544a55cf 100644 --- a/extra/ui/tools/tools-docs.factor +++ b/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-gadget "other" } -"Walkers are instances of " { $link walker-gadget } "." ; +{ $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." diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 135bd0745e..3e59583eb6 100644 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -17,7 +17,7 @@ IN: ui.tools - + } ; @@ -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 ; diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 7cbb758969..d979500002 100644 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/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" set ] unit-test +[ ] [ "w" set ] unit-test + [ ] [ "w" set ] unit-test continuation "c" set [ ] [ "c" get "w" get call-tool* ] unit-test diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 453ab08976..e5dc77a59b 100644 --- a/extra/ui/tools/walker/walker.factor +++ b/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 -- ) - swap dup walker-gadget-ns [ slip update-stacks ] bind ; - inline +: with-walker ( walker quot -- ) + over >r >r walker-interpreter r> call r> + 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 ; -: com-into [ step-into ] walker-command ; -: com-out [ step-out ] walker-command ; -: com-back [ step-back ] walker-command ; +: save-interpreter ( walker -- ) + dup walker-interpreter interpreter-continuation clone + swap walker-history push ; -: init-walker-models ( walker -- ) - f over set-walker-gadget-model - H{ } clone swap set-walker-gadget-ns ; +: com-step ( walker -- ) + dup save-interpreter [ step ] walker-command ; + +: 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 - [ V{ } clone history set ] with-walker ; + over set-walker-interpreter + V{ } clone over set-walker-history + update-stacks ; -: ( -- gadget ) - walker-gadget construct-empty - dup init-walker-models [ +: ( -- gadget ) + f f f walker construct-boa [ toolbar, - g walker-gadget-model 1 track, + g walker-model 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